home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / WEBSITES / FORTRAN_FRIENDS / PGPLOT.ZIP / f77 / PGPLOT < prev    next >
Text File  |  1996-11-05  |  535KB  |  15,643 lines
  1. C*GRAREA -- define a clipping window
  2. C+
  3.       SUBROUTINE GRAREA (IDENT,X0,Y0,XSIZE,YSIZE)
  4. C
  5. C GRPCKG: Define a rectangular window in the current plotting area. All
  6. C graphics (except characters written with GRCHAR) will be blanked
  7. C outside this window.  The default window is the full plotting area
  8. C defined by default or by GRSETS.
  9. C
  10. C Arguments:
  11. C
  12. C IDENT (input, integer): the plot identifier, returned by GROPEN.
  13. C X0, Y0 (input, real): the lower left corner of the window, in absolute
  14. C       device coordinates.
  15. C XSIZE, YSIZE (input, real): width and height of the window in absolute
  16. C       coordinates; if either is negative, the window will be reset to
  17. C       the full plotting area.
  18. C--
  19. C  1-Feb-1983 - [TJP].
  20. C 25-Nov-1994 - use floating-point [TJP].
  21. C-----------------------------------------------------------------------
  22.       INCLUDE 'f77.GRPCKG1/IN'
  23.       INTEGER IDENT
  24.       REAL X0, Y0, XSIZE, YSIZE
  25. C
  26.       CALL GRSLCT(IDENT)
  27. C
  28.       IF ((XSIZE.LE.0.0) .OR. (YSIZE.LE.0.0)) THEN
  29.           GRXMIN(IDENT) = 0
  30.           GRXMAX(IDENT) = GRXMXA(IDENT)
  31.           GRYMIN(IDENT) = 0
  32.           GRYMAX(IDENT) = GRYMXA(IDENT)
  33.       ELSE
  34.           GRXMIN(IDENT) = MAX(X0,0.0)
  35.           GRYMIN(IDENT) = MAX(Y0,0.0)
  36.           GRXMAX(IDENT) = MIN(XSIZE+X0,REAL(GRXMXA(IDENT)))
  37.           GRYMAX(IDENT) = MIN(YSIZE+Y0,REAL(GRYMXA(IDENT)))
  38.       END IF
  39. C
  40.       END
  41. C*GRBPIC -- begin picture
  42. C+
  43.       SUBROUTINE GRBPIC
  44. C
  45. C GRPCKG (internal routine). Send a "begin picture" command to the
  46. C device driver, and send commands to set deferred attributes (color,
  47. C line width, etc.)
  48. C-----------------------------------------------------------------------
  49.       INCLUDE 'f77.GRPCKG1/IN'
  50.       REAL RBUF(2)
  51.       INTEGER NBUF, LCHR
  52.       CHARACTER*20 CHR
  53. C
  54.       GRPLTD(GRCIDE) = .TRUE.
  55.       IF (GRGTYP.GT.0) THEN
  56. C         -- begin picture
  57.           RBUF(1) = GRXMXA(GRCIDE)
  58.           RBUF(2) = GRYMXA(GRCIDE)
  59.           NBUF = 2
  60.           CALL GREXEC(GRGTYP,11,RBUF,NBUF,CHR,LCHR)
  61. C         -- set color index
  62.           RBUF(1) = GRCCOL(GRCIDE)
  63.           NBUF = 1
  64.           CALL GREXEC(GRGTYP,15,RBUF,NBUF,CHR,LCHR)
  65. C         -- set line width
  66.           IF (GRGCAP(GRCIDE)(5:5).EQ.'T') THEN
  67.               RBUF(1) = ABS(GRWIDT(GRCIDE))
  68.               NBUF = 1
  69.               CALL GREXEC(GRGTYP,22,RBUF,NBUF,CHR,LCHR)
  70.           END IF
  71. C         -- set hardware dashing
  72.           IF (GRGCAP(GRCIDE)(3:3).EQ.'D') THEN
  73.               RBUF(1) = GRSTYL(GRCIDE)
  74.               NBUF = 1
  75.               CALL GREXEC(GRGTYP,19,RBUF,NBUF,CHR,LCHR)
  76.           END IF
  77.       END IF
  78. C
  79.       END
  80. C+
  81. ***********************************************************************
  82. *                                                                     *
  83. *  PGPLOT Fortran Graphics Subroutine Library                         *
  84. *                                                                     *
  85. *  T. J. Pearson, California Institute of Technology,                 *
  86. *  Pasadena, California 91125.                                        *
  87. *                                                                     *
  88. *  Routines for handling the obsolete character set                   *
  89. *  ------------------------------------------------                   *
  90. *  These routines are not called by PGPLOT but are called by some     *
  91. *  old user-written programs.                                         *
  92. ***********************************************************************
  93.  
  94. ******* Index of Modules **********************************************
  95.  
  96. * GRCHAR -- draw a string of characters
  97. * GRCHR0 -- support routine for GRCHAR and GRMARK
  98. * GRDAT2 -- character set definition (block data)
  99. * GRGTC0 -- obtain character digitization
  100. * GRMARK -- mark points with specified symbol
  101.  
  102. ***********************************************************************
  103. C--
  104.  
  105. C*GRCHAR -- draw a string of characters
  106. C+
  107.       SUBROUTINE GRCHAR (IDENT,CENTER,ORIENT,ABSXY,X0,Y0,STRING)
  108. C
  109. C GRPCKG: Draw a string of characters. The plot is not windowed
  110. C in the current subarea, but in the full plotting area.
  111. C
  112. C Arguments:
  113. C
  114. C IDENT (input, integer): plot identifier, as returned by GROPEN.
  115. C CENTER (input, logical): if .TRUE., the first character of the string
  116. C      is centered at (X0,Y0); otherwise the bottom left corner of the
  117. C      first character is placed at (X0,Y0).
  118. C ORIENT (input, real): the angle in degrees that the string is to make
  119. C      with the horizontal, increasing anticlockwise.
  120. C ABSXY (input, logical): if .TRUE., (X0,Y0) are absolute device
  121. C      coordinates; otherwise they are world coordinates (the scaling
  122. C      transformation is applied).
  123. C X0, Y0 (input, real): position of first character (see CENTER).
  124. C STRING (input, character): the string of ASCII characters; control
  125. C      characters 0-20 have special representations; all other
  126. C      non-graphic characters are plotted as blank spaces.
  127. C
  128. C (1-Feb-1983)
  129. C-----------------------------------------------------------------------
  130.       CHARACTER*(*) STRING
  131.       INTEGER  IDENT
  132.       LOGICAL  ABSXY, CENTER
  133.       REAL     ORIENT, X0, Y0
  134. C
  135.       CALL GRSLCT(IDENT)
  136.       CALL GRCHR0(.FALSE., CENTER, ORIENT, ABSXY, X0, Y0, STRING)
  137.       RETURN
  138.       END
  139. C*GRCHR0 -- support routine for GRCHAR and GRMARK
  140. C+
  141.       SUBROUTINE GRCHR0 (WINDOW,CENTER,ORIENT,ABSXY,X0,Y0,STRING)
  142. C
  143. C GRPCKG (internal routine): Support routine for GRCHAR and GRMARK.
  144. C Draw a string of characters.
  145. C
  146. C Arguments:
  147. C
  148. C WINDOW (input, logical): if .TRUE., the plot is windowed in the
  149. C      current window.
  150. C CENTER (input, logical): if .TRUE., the first character of the string
  151. C      is centered at (X0,Y0); otherwise the bottom left corner of the
  152. C      first character is placed at (X0,Y0).
  153. C ORIENT (input, real): the angle in degrees that the string is to make
  154. C      with the horizontal, increasing anticlockwise.
  155. C ABSXY (input, logical): if .TRUE., (X0,Y0) are absolute device
  156. C      coordinates; otherwise they are world coordinates (the scaling
  157. C      transformation is applied).
  158. C X0, Y0 (input, real): position of first character (see CENTER).
  159. C STRING (input, character): the string of ASCII characters; control
  160. C      characters 0-20 have special representations; all other
  161. C      non-graphic characters are plotted as blank spaces.
  162. C
  163. C (1-Mar-1983)
  164. C-----------------------------------------------------------------------
  165.       INTEGER  DOT, MOVE, VECSIZ
  166.       REAL     PI
  167.       PARAMETER (DOT = 3)
  168.       PARAMETER (MOVE = 2)
  169.       PARAMETER (VECSIZ = 30)
  170.       PARAMETER (PI = 3.14159265)
  171.       INCLUDE 'f77.GRPCKG1/IN'
  172.       CHARACTER*(*) STRING
  173.       CHARACTER*1   NEXT
  174.       REAL     XMIN, XMAX, YMIN, YMAX
  175.       INTEGER  MODE,LSTYLE,LEVEL
  176.       INTEGER  I, J, L, CH, POINTS
  177.       LOGICAL  ABSXY, CENTER, MORE, WINDOW
  178.       REAL     ORIENT, X0, Y0
  179.       REAL     ANGLE, FACTOR, BASE, FAC
  180.       REAL     COSA, SINA
  181.       REAL     DX, DY, XORG, YORG
  182.       REAL     XC(VECSIZ), YC(VECSIZ), XT, YT
  183. C
  184.       IF (LEN(STRING).LE.0) RETURN
  185. C
  186. C Compute scaling and orientation.
  187. C
  188.       CALL GRQLS(LSTYLE)
  189.       CALL GRSLS(1)
  190.       ANGLE = (AMOD(ORIENT, 360.0) / 180.0) * PI
  191.       FACTOR = GRCFAC(GRCIDE)
  192.       COSA = FACTOR * COS(ANGLE)
  193.       SINA = FACTOR * SIN(ANGLE)
  194.       DX = GRCXSP * COSA
  195.       DY = GRCXSP * SINA
  196.       CALL GRTXY0(ABSXY, X0, Y0, XORG, YORG)
  197.       IF (.NOT.WINDOW) THEN
  198.           XMIN = GRXMIN(GRCIDE)
  199.           XMAX = GRXMAX(GRCIDE)
  200.           YMIN = GRYMIN(GRCIDE)
  201.           YMAX = GRYMAX(GRCIDE)
  202.           CALL GRAREA(GRCIDE, 0.0, 0.0, 0.0, 0.0)
  203.       END IF
  204. C
  205. C Plot the string of characters.
  206. C
  207.       MODE = MOVE
  208.       BASE = 0.0
  209.       FAC = 1.0
  210.       I = 1
  211.       LEVEL = 0
  212.       L = LEN(STRING)
  213. C     -- DO WHILE (I.LE.L)
  214.    10 IF (I.LE.L) THEN
  215.         IF (I.LT.L .AND. STRING(I:I).EQ.CHAR(92)) THEN
  216.             CALL GRTOUP(NEXT,STRING(I+1:I+1))
  217.             IF (NEXT.EQ.'U') THEN
  218.                 LEVEL = LEVEL+1
  219.                 BASE = BASE + 4.0*FAC
  220.                 FAC = 0.6**IABS(LEVEL)
  221.                 I = I+2
  222.             ELSE IF (NEXT.EQ.'D') THEN
  223.                 LEVEL = LEVEL-1
  224.                 FAC = 0.6**IABS(LEVEL)
  225.                 BASE = BASE - 4.0*FAC
  226.                 I = I+2
  227.             ELSE
  228.                 I = I+1
  229.             END IF
  230.         ELSE
  231.           CH = ICHAR(STRING(I:I))
  232.           IF (CH.GT.127 .OR. CH.LT.0) CH = ICHAR(' ')
  233.           MORE = .TRUE.
  234. C         -- DO WHILE (MORE)
  235.    20     IF (MORE) THEN
  236.             CALL GRGTC0(CH, CENTER, POINTS, XC, YC, MORE)
  237.             DO 30 J=1,POINTS
  238.                     XT = XC(J)*FAC
  239.                     YT = YC(J)*FAC + BASE
  240.                     XC(J) = XORG + COSA * XT - SINA * YT
  241.                     YC(J) = YORG + SINA * XT + COSA * YT
  242.    30       CONTINUE
  243.             IF (POINTS.EQ.1) MODE = DOT
  244.             IF (POINTS.GT.0) CALL GRVCT0(MODE,.TRUE.,POINTS,XC,YC)
  245.             IF (POINTS.EQ.1) MODE = MOVE
  246.           GOTO 20
  247.           END IF
  248. C         -- end DO WHILE
  249.           XORG = XORG + DX*FAC
  250.           YORG = YORG + DY*FAC
  251.           I = I+1
  252.         END IF
  253.       GOTO 10
  254.       END IF
  255. C     -- end DO WHILE
  256. C
  257. C Clean up and return.
  258. C
  259.       IF (.NOT.WINDOW) THEN
  260.           GRXMIN(GRCIDE) = XMIN
  261.           GRXMAX(GRCIDE) = XMAX
  262.           GRYMIN(GRCIDE) = YMIN
  263.           GRYMAX(GRCIDE) = YMAX
  264.       END IF
  265.       CALL GRSLS(LSTYLE)
  266.       RETURN
  267.       END
  268.  
  269. C*GRCHSZ -- inquire default character attributes
  270. C+
  271.       SUBROUTINE GRCHSZ (IDENT,XSIZE,YSIZE,XSPACE,YSPACE)
  272. C
  273. C GRPCKG: Obtain the default character attributes.
  274. C
  275. C Arguments:
  276. C
  277. C IDENT (input, integer): the plot identifier, returned by GROPEN.
  278. C XSIZE, YSIZE (output, real): the default character size
  279. C      (absolute device units).
  280. C XSPACE, YSPACE (output, real): the default character spacing
  281. C      (absolute units); XSPACE is the distance between the lower left
  282. C      corners of adjacent characters in a plotted string; YSPACE
  283. C      is the corresponding vertical spacing.
  284. C--
  285. C (1-Feb-1983)
  286. C-----------------------------------------------------------------------
  287.       INCLUDE 'f77.GRPCKG1/IN'
  288.       INTEGER  IDENT
  289.       REAL     FACTOR, XSIZE, YSIZE, XSPACE, YSPACE
  290. C
  291.       CALL GRSLCT(IDENT)
  292.       FACTOR = GRCSCL(IDENT)
  293.       XSIZE = GRCXSZ * FACTOR
  294.       YSIZE = GRCYSZ * FACTOR
  295.       XSPACE = GRCXSP * FACTOR
  296.       YSPACE = GRCYSP * FACTOR
  297.       END
  298. C*GRCLIP -- clip a point against clipping rectangle
  299. C+
  300.       SUBROUTINE GRCLIP (X,Y,XMIN,XMAX,YMIN,YMAX,C)
  301.       REAL X,Y
  302.       REAL XMIN,XMAX,YMIN,YMAX
  303.       INTEGER C
  304. C
  305. C GRPCKG (internal routine): support routine for the clipping algorithm;
  306. C called from GRLIN0 only. C is a 4 bit code indicating the relationship
  307. C between point (X,Y) and the window boundaries; 0 implies the point is
  308. C within the window.
  309. C
  310. C Arguments:
  311. C--
  312. C (11-Feb-1983)
  313. C Revised 20-Jun-1985 (TJP); use floating arithmetic
  314. C Revised 12-Jun-1992 (TJP); clip exactly on the boundary
  315. C-----------------------------------------------------------------------
  316. C
  317.       C = 0
  318.       IF (X.LT.XMIN) THEN
  319.           C = 1
  320.       ELSE IF (X.GT.XMAX) THEN
  321.           C = 2
  322.       END IF
  323.       IF (Y.LT.YMIN) THEN
  324.           C = C+4
  325.       ELSE IF (Y.GT.YMAX) THEN
  326.           C = C+8
  327.       END IF
  328.       END
  329. C*GRCLOS -- close graphics device
  330. C+
  331.       SUBROUTINE GRCLOS
  332. C
  333. C GRPCKG: Close the open plot on the current device. Any pending output
  334. C is sent to the device, the device is released for other users or the
  335. C disk file is closed, and no further plotting is allowed on the device
  336. C without a new call to GROPEN.
  337. C
  338. C Arguments: none.
  339. C--
  340. C  1-Jun-1984 - [TJP].
  341. C 17-Jul-1984 - ignore call if plot is not open [TJP].
  342. C  1-Oct-1984 - reset color to default (1) and position text cursor
  343. C               at bottom of VT screen [TJP].
  344. C 19-Oct-1984 - add VV device [TJP].
  345. C 22-Dec-1984 - use GRBUFL and GRIOTA parameters [TJP].
  346. C  5-Aug-1986 - add GREXEC support [AFT].
  347. C 21-Feb-1987 - modify END_PICTURE sequence [AFT].
  348. C 11-Jun-1987 - remove built-ins [TJP].
  349. C 31-Aug-1987 - do not eject blank page [TJP].
  350. C-----------------------------------------------------------------------
  351.       INCLUDE 'f77.GRPCKG1/IN'
  352.       REAL    RBUF(6)
  353.       INTEGER NBUF,LCHR
  354.       CHARACTER CHR
  355. C
  356. C Check a plot is open.
  357. C
  358.       IF (GRCIDE.LT.1) RETURN
  359. C
  360. C Reset color to default (1). This is useful
  361. C for VT240 terminals, which use the color tables for text.
  362. C
  363.       CALL GRSCI(1)
  364. C
  365. C Flush buffer.
  366. C
  367.       CALL GRTERM
  368. C
  369. C End picture.
  370. C
  371.       CALL GREPIC
  372. C
  373. C This plot identifier is no longer in use.
  374. C Set state to "workstation closed".
  375. C
  376.       GRSTAT(GRCIDE) = 0
  377.       GRCIDE = 0
  378. C
  379. C Close workstation.
  380. C
  381.       CALL GREXEC(GRGTYP,10,RBUF,NBUF,CHR,LCHR)
  382. C
  383.       END
  384. C*GRCLPL -- clip line against clipping rectangle
  385. C+
  386.       SUBROUTINE GRCLPL (X0,Y0,X1,Y1,VIS)
  387. C
  388. C GRPCKG (internal routine): Change the end-points of the line (X0,Y0)
  389. C (X1,Y1) to clip the line at the window boundary.  The algorithm is
  390. C that of Cohen and Sutherland (ref: Newman & Sproull).
  391. C
  392. C Arguments:
  393. C
  394. C X0, Y0 (input/output, real): device coordinates of starting point
  395. C       of line.
  396. C X1, Y1 (input/output, real): device coordinates of end point of line.
  397. C VIS (output, logical): .TRUE. if line lies wholly or partially
  398. C       within the clipping rectangle; .FALSE. if it lies entirely
  399. C       outside the rectangle.
  400. C--
  401. C 13-Jul-1984 - [TJP].
  402. C 20-Jun-1985 - [TJP] - revise clipping algorithm.
  403. C 28-Jun-1991 - [TJP] - use IAND().
  404. C 12-Jun-1992 - [TJP] - clip exactly on the boundary.
  405. C
  406. C Caution: IAND is a non-standard intrinsic function to do bitwise AND
  407. C of two integers. If it is not supported by your Fortran compiler, you
  408. C will need to modify this routine or supply an IAND function.
  409. C-----------------------------------------------------------------------
  410.       INCLUDE 'f77.GRPCKG1/IN'
  411.       LOGICAL  VIS
  412.       INTEGER  C0,C1,C
  413.       REAL     XMIN,XMAX,YMIN,YMAX
  414.       REAL     X,Y, X0,Y0, X1,Y1
  415.       INTEGER IAND
  416. C
  417.       XMIN = GRXMIN(GRCIDE)
  418.       YMIN = GRYMIN(GRCIDE)
  419.       XMAX = GRXMAX(GRCIDE)
  420.       YMAX = GRYMAX(GRCIDE)
  421.       CALL GRCLIP(X0,Y0,XMIN,XMAX,YMIN,YMAX,C0)
  422.       CALL GRCLIP(X1,Y1,XMIN,XMAX,YMIN,YMAX,C1)
  423.    10 IF (C0.NE.0 .OR. C1.NE.0) THEN
  424.           IF (IAND(C0,C1).NE.0) THEN
  425. C             ! line is invisible
  426.               VIS = .FALSE.
  427.               RETURN
  428.           END IF
  429.           C = C0
  430.           IF (C.EQ.0) C = C1
  431.           IF (IAND(C,1).NE.0) THEN
  432. C             ! crosses XMIN
  433.               Y = Y0 + (Y1-Y0)*(XMIN-X0)/(X1-X0)
  434.               X = XMIN
  435.           ELSE IF (IAND(C,2).NE.0) THEN
  436. C             ! crosses XMAX
  437.               Y = Y0 + (Y1-Y0)*(XMAX-X0)/(X1-X0)
  438.               X = XMAX
  439.           ELSE IF (IAND(C,4).NE.0) THEN
  440. C             ! crosses YMIN
  441.               X = X0 + (X1-X0)*(YMIN-Y0)/(Y1-Y0)
  442.               Y = YMIN
  443.           ELSE IF (IAND(C,8).NE.0) THEN
  444. C             ! crosses YMAX
  445.               X = X0 + (X1-X0)*(YMAX-Y0)/(Y1-Y0)
  446.               Y = YMAX
  447.           END IF
  448.           IF (C.EQ.C0) THEN
  449.               X0 = X
  450.               Y0 = Y
  451.               CALL GRCLIP(X,Y,XMIN,XMAX,YMIN,YMAX,C0)
  452.           ELSE
  453.               X1 = X
  454.               Y1 = Y
  455.               CALL GRCLIP(X,Y,XMIN,XMAX,YMIN,YMAX,C1)
  456.           END IF
  457.       GOTO 10
  458.       END IF
  459.       VIS = .TRUE.
  460.       END
  461. C*GRCTOI -- convert character string to integer
  462. C+
  463.       INTEGER FUNCTION GRCTOI (S, I)
  464.       CHARACTER*(*) S
  465.       INTEGER I
  466. C
  467. C GRCTOI: attempt to read an integer from a character string, and return
  468. C the result. No attempt is made to avoid integer overflow. A valid 
  469. C integer is any sequence of decimal digits.
  470. C
  471. C Returns:
  472. C  GRCTOI           : the value of the integer; if the first character
  473. C                    read is not a decimal digit, the value returned
  474. C                    is zero.
  475. C Arguments:
  476. C  S      (input)  : character string to be parsed.
  477. C  I      (in/out) : on input, I is the index of the first character
  478. C                    in S to be examined; on output, either it points
  479. C                    to the next character after a valid integer, or
  480. C                    it is equal to LEN(S)+1.
  481. C
  482. C--
  483. C  1985 Oct  8 - New routine, based on CTOI (T. J. Pearson).
  484. C-----------------------------------------------------------------------
  485.       INTEGER K
  486.       CHARACTER*1 DIGITS(0:9)
  487.       DATA  DIGITS/'0','1','2','3','4','5','6','7','8','9'/
  488. C
  489.       GRCTOI = 0
  490.    10 IF (I.GT.LEN(S)) RETURN
  491.       DO 20 K=0,9
  492.           IF (S(I:I).EQ.DIGITS(K)) GOTO 30
  493.    20 CONTINUE
  494.       RETURN
  495.    30 GRCTOI = GRCTOI*10 + K
  496.       I = I+1
  497.       GOTO 10
  498.       END
  499. C*GRCURS -- read cursor position
  500. C+
  501.       INTEGER FUNCTION GRCURS (IDENT,IX,IY,IXREF,IYREF,MODE,POSN,CH)
  502.       INTEGER IDENT, IX, IY, IXREF, IYREF, MODE, POSN
  503.       CHARACTER*(*) CH
  504. C
  505. C GRPCKG: Read the cursor position and a character typed by the user.
  506. C The position is returned in absolute device coordinates (pixels).
  507. C GRCURS positions the cursor at the position specified, and
  508. C allows the user to move the cursor using the joystick or
  509. C arrow keys or whatever is available on the device. When he has
  510. C positioned the cursor, the user types a single character on his
  511. C keyboard; GRCURS then returns this character and the new cursor
  512. C position.
  513. C
  514. C "Rubber band" feedback of cursor movement can be requested (although
  515. C it may not be supported on some devices). If MODE=1, a line from
  516. C the anchor point to the current cursor position is displayed as
  517. C the cursor is moved. If MODE=2, a rectangle with vertical and
  518. C horizontal sides and one vertex at the anchor point and the opposite
  519. C vertex at the current cursor position is displayed as the cursor is
  520. C moved.
  521. C
  522. C Returns:
  523. C
  524. C GRCURS (integer): 1 if the call was successful; 0 if the device
  525. C      has no cursor or some other error occurs. 
  526. C
  527. C Arguments:
  528. C
  529. C IDENT (integer, input):  GRPCKG plot identifier (from GROPEN).
  530. C IX    (integer, in/out): the device x-coordinate of the cursor.
  531. C IY    (integer, in/out): the device y-coordinate of the cursor.
  532. C IXREF (integer, input):  x-coordinate of anchor point.
  533. C IYREF (integer, input):  y-coordinate of anchor point.
  534. C MODE  (integer, input):  type of rubber-band feedback.
  535. C CH    (char,    output): the character typed by the user; if the device
  536. C      has no cursor or if some other error occurs, the value CHAR(0)
  537. C      [ASCII NUL character] is returned.
  538. C--
  539. C  1-Aug-1984 - extensively revised [TJP].
  540. C 29-Jan-1985 - add ARGS and HP2648 devices (?) [KS/TJP].
  541. C  5-Aug-1986 - add GREXEC support [AFT].
  542. C 11-Jun-1987 - remove built-ins [TJP].
  543. C 15-Feb-1988 - remove test for batch jobs; leave this to the device
  544. C               handler [TJP].
  545. C 13-Dec-1990 - remove code to abort after 10 cursor errors [TJP].
  546. C  7-Sep-1994 - add support for rubber-band modes [TJP].
  547. C 17-Jan-1995 - start picture if necessary [TJP].
  548. C-----------------------------------------------------------------------
  549.       INCLUDE 'f77.GRPCKG1/IN'
  550.       REAL           RBUF(6)
  551.       INTEGER        NBUF, LCHR, ICURS, ERRCNT
  552.       CHARACTER*16   CHR
  553.       CHARACTER      C
  554.       SAVE           ERRCNT
  555.       DATA           ERRCNT/0/
  556. C
  557. C Validate identifier, and select device.
  558. C
  559.       CALL GRSLCT(IDENT)
  560.       CALL GRTERM
  561. C
  562. C Begin picture if necessary.
  563. C
  564.       IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  565. C
  566. C Make sure cursor is on view surface. (It does not
  567. C have to be in the viewport.)
  568. C
  569.       IX = MAX(0,MIN(GRXMXA(GRCIDE),IX))
  570.       IY = MAX(0,MIN(GRYMXA(GRCIDE),IY))
  571. C
  572. C Does the device have a cursor?
  573. C
  574.       C = GRGCAP(GRCIDE)(2:2)
  575.       ICURS = 0
  576.       IF (C.EQ.'C' .OR. C.EQ.'X') ICURS=1
  577. C
  578. C Device does have a cursor.
  579. C
  580.       IF (ICURS.GT.0) THEN
  581. C         -- initial position of cursor
  582.           RBUF(1) = IX
  583.           RBUF(2) = IY
  584. C         -- reference point for rubber band
  585.           RBUF(3) = IXREF
  586.           RBUF(4) = IYREF
  587. C         -- rubber band mode
  588.           RBUF(5) = MODE
  589. C         -- position cursor?
  590.           RBUF(6) = POSN
  591.           NBUF = 6
  592.           LCHR = 0
  593.           CALL GREXEC(GRGTYP,17,RBUF,NBUF,CHR,LCHR)
  594.           IX = RBUF(1)
  595.           IY = RBUF(2)
  596.           CH = CHR(1:1)
  597.           GRCURS = 1
  598. C         -- error if driver returns NUL
  599.           IF (ICHAR(CHR(1:1)).EQ.0) GRCURS = 0
  600. C
  601. C Other devices are illegal.
  602. C
  603.       ELSE
  604.           CALL GREXEC(GRGTYP, 1,RBUF,NBUF,CHR,LCHR)
  605.           LCHR = INDEX(CHR,' ')
  606.           IF (ERRCNT.LE.10) CALL 
  607.      1        GRWARN('output device has no cursor: '//CHR(:LCHR))
  608.           CH = CHAR(0)
  609.           GRCURS = 0
  610.           ERRCNT = ERRCNT+1
  611.       END IF
  612. C
  613.       END
  614.  
  615. C*GRDAT2 -- character set definition (block data)
  616. C+
  617.       BLOCK DATA GRDAT2
  618. C
  619. C GRPCKG (internal routine): Block data for to define the character set.
  620. C
  621. C Arguments: none.
  622. C
  623. C (1-Feb-1983)
  624. C-----------------------------------------------------------------------
  625.       INTEGER   CTD1, CTD2
  626.       PARAMETER (CTD1 = 30)
  627.       PARAMETER (CTD2 = 128)
  628. C
  629.       INTEGER   CINDX1, CINDX2
  630.       INTEGER   CHTBL(CTD1,CTD2)
  631.       INTEGER   SPCH00(CTD1), SPCH01(CTD1), SPCH02(CTD1), SPCH03(CTD1)
  632.      1        , SPCH04(CTD1), SPCH05(CTD1), SPCH06(CTD1), SPCH07(CTD1)
  633.      2        , SPCH08(CTD1), SPCH09(CTD1), SPCH10(CTD1), SPCH11(CTD1)
  634.      3        , SPCH12(CTD1), SPCH13(CTD1), SPCH14(CTD1), SPCH15(CTD1)
  635.      4        , SPCH16(CTD1), SPCH17(CTD1), SPCH18(CTD1), SPCH19(CTD1)
  636.      5        , SPCH20(CTD1), SPCH21(CTD1), SPCH22(CTD1), SPCH23(CTD1)
  637.      6        , SPCH24(CTD1), SPCH25(CTD1), SPCH26(CTD1), SPCH27(CTD1)
  638.      7        , SPCH28(CTD1), SPCH29(CTD1), SPCH30(CTD1), SPCH31(CTD1)
  639.      8        , SPACE (CTD1), EXCLAM(CTD1), QUOTE (CTD1), POUND (CTD1)
  640.      9        , DOLLAR(CTD1), PERCNT(CTD1), AMPERS(CTD1), APOSTR(CTD1)
  641.      A        , LPAREN(CTD1), RPAREN(CTD1), ASTER (CTD1), PLUS  (CTD1)
  642.      B        , COMMA (CTD1), MINUS (CTD1), PERIOD(CTD1), SLASH (CTD1)
  643.      C        , ZERO  (CTD1), ONE   (CTD1), TWO   (CTD1), THREE (CTD1)
  644.      D        , FOUR  (CTD1), FIVE  (CTD1), SIX   (CTD1), SEVEN (CTD1)
  645.      E        , EIGHT (CTD1), NINE  (CTD1), COLON (CTD1), SEMICO(CTD1)
  646.      F        , LESS  (CTD1), EQUALS(CTD1), GREATR(CTD1), QUESTN(CTD1)
  647.       INTEGER   ATSIGN(CTD1), AUPPER(CTD1), BUPPER(CTD1), CUPPER(CTD1)
  648.      1        , DUPPER(CTD1), EUPPER(CTD1), FUPPER(CTD1), GUPPER(CTD1)
  649.      2        , HUPPER(CTD1), IUPPER(CTD1), JUPPER(CTD1), KUPPER(CTD1)
  650.      3        , LUPPER(CTD1), MUPPER(CTD1), NUPPER(CTD1), OUPPER(CTD1)
  651.      4        , PUPPER(CTD1), QUPPER(CTD1), RUPPER(CTD1), SUPPER(CTD1)
  652.      5        , TUPPER(CTD1), UUPPER(CTD1), VUPPER(CTD1), WUPPER(CTD1)
  653.      6        , XUPPER(CTD1), YUPPER(CTD1), ZUPPER(CTD1), LBRACK(CTD1)
  654.      7        , BKSLSH(CTD1), RBRACK(CTD1), CARET (CTD1), USCORE(CTD1)
  655.      8        , ACCENT(CTD1), ALOWER(CTD1), BLOWER(CTD1), CLOWER(CTD1)
  656.      9        , DLOWER(CTD1), ELOWER(CTD1), FLOWER(CTD1), GLOWER(CTD1)
  657.      A        , HLOWER(CTD1), ILOWER(CTD1), JLOWER(CTD1), KLOWER(CTD1)
  658.      B        , LLOWER(CTD1), MLOWER(CTD1), NLOWER(CTD1), OLOWER(CTD1)
  659.      C        , PLOWER(CTD1), QLOWER(CTD1), RLOWER(CTD1), SLOWER(CTD1)
  660.      D        , TLOWER(CTD1), ULOWER(CTD1), VLOWER(CTD1), WLOWER(CTD1)
  661.      E        , XLOWER(CTD1), YLOWER(CTD1), ZLOWER(CTD1), LBRACE(CTD1)
  662.      F        , ORSIGN(CTD1), RBRACE(CTD1), TILDE (CTD1), SPC127(CTD1)
  663.       EQUIVALENCE (SPCH00, CHTBL(1,   1)), (SPCH01, CHTBL(1,   2))
  664.      1          , (SPCH02, CHTBL(1,   3)), (SPCH03, CHTBL(1,   4))
  665.      2          , (SPCH04, CHTBL(1,   5)), (SPCH05, CHTBL(1,   6))
  666.      3          , (SPCH06, CHTBL(1,   7)), (SPCH07, CHTBL(1,   8))
  667.      4          , (SPCH08, CHTBL(1,   9)), (SPCH09, CHTBL(1,  10))
  668.      5          , (SPCH10, CHTBL(1,  11)), (SPCH11, CHTBL(1,  12))
  669.      6          , (SPCH12, CHTBL(1,  13)), (SPCH13, CHTBL(1,  14))
  670.      7          , (SPCH14, CHTBL(1,  15)), (SPCH15, CHTBL(1,  16))
  671.      8          , (SPCH16, CHTBL(1,  17)), (SPCH17, CHTBL(1,  18))
  672.      9          , (SPCH18, CHTBL(1,  19)), (SPCH19, CHTBL(1,  20))
  673.      A          , (SPCH20, CHTBL(1,  21)), (SPCH21, CHTBL(1,  22))
  674.      B          , (SPCH22, CHTBL(1,  23)), (SPCH23, CHTBL(1,  24))
  675.      C          , (SPCH24, CHTBL(1,  25)), (SPCH25, CHTBL(1,  26))
  676.      D          , (SPCH26, CHTBL(1,  27)), (SPCH27, CHTBL(1,  28))
  677.      E          , (SPCH28, CHTBL(1,  29)), (SPCH29, CHTBL(1,  30))
  678.      F          , (SPCH30, CHTBL(1,  31)), (SPCH31, CHTBL(1,  32))
  679.       EQUIVALENCE (SPACE , CHTBL(1,  33)), (EXCLAM, CHTBL(1,  34))
  680.      1          , (QUOTE , CHTBL(1,  35)), (POUND , CHTBL(1,  36))
  681.      2          , (DOLLAR, CHTBL(1,  37)), (PERCNT, CHTBL(1,  38))
  682.      3          , (AMPERS, CHTBL(1,  39)), (APOSTR, CHTBL(1,  40))
  683.      4          , (LPAREN, CHTBL(1,  41)), (RPAREN, CHTBL(1,  42))
  684.      5          , (ASTER , CHTBL(1,  43)), (PLUS  , CHTBL(1,  44))
  685.      6          , (COMMA , CHTBL(1,  45)), (MINUS , CHTBL(1,  46))
  686.      7          , (PERIOD, CHTBL(1,  47)), (SLASH , CHTBL(1,  48))
  687.      8          , (ZERO  , CHTBL(1,  49)), (ONE   , CHTBL(1,  50))
  688.      9          , (TWO   , CHTBL(1,  51)), (THREE , CHTBL(1,  52))
  689.      A          , (FOUR  , CHTBL(1,  53)), (FIVE  , CHTBL(1,  54))
  690.      B          , (SIX   , CHTBL(1,  55)), (SEVEN , CHTBL(1,  56))
  691.      C          , (EIGHT , CHTBL(1,  57)), (NINE  , CHTBL(1,  58))
  692.      D          , (COLON , CHTBL(1,  59)), (SEMICO, CHTBL(1,  60))
  693.      E          , (LESS  , CHTBL(1,  61)), (EQUALS, CHTBL(1,  62))
  694.      F          , (GREATR, CHTBL(1,  63)), (QUESTN, CHTBL(1,  64))
  695.       EQUIVALENCE (ATSIGN, CHTBL(1,  65)), (AUPPER, CHTBL(1,  66))
  696.      1          , (BUPPER, CHTBL(1,  67)), (CUPPER, CHTBL(1,  68))
  697.      2          , (DUPPER, CHTBL(1,  69)), (EUPPER, CHTBL(1,  70))
  698.      3          , (FUPPER, CHTBL(1,  71)), (GUPPER, CHTBL(1,  72))
  699.      4          , (HUPPER, CHTBL(1,  73)), (IUPPER, CHTBL(1,  74))
  700.      5          , (JUPPER, CHTBL(1,  75)), (KUPPER, CHTBL(1,  76))
  701.      6          , (LUPPER, CHTBL(1,  77)), (MUPPER, CHTBL(1,  78))
  702.      7          , (NUPPER, CHTBL(1,  79)), (OUPPER, CHTBL(1,  80))
  703.      8          , (PUPPER, CHTBL(1,  81)), (QUPPER, CHTBL(1,  82))
  704.      9          , (RUPPER, CHTBL(1,  83)), (SUPPER, CHTBL(1,  84))
  705.      A          , (TUPPER, CHTBL(1,  85)), (UUPPER, CHTBL(1,  86))
  706.      B          , (VUPPER, CHTBL(1,  87)), (WUPPER, CHTBL(1,  88))
  707.      C          , (XUPPER, CHTBL(1,  89)), (YUPPER, CHTBL(1,  90))
  708.      D          , (ZUPPER, CHTBL(1,  91)), (LBRACK, CHTBL(1,  92))
  709.      E          , (BKSLSH, CHTBL(1,  93)), (RBRACK, CHTBL(1,  94))
  710.      F          , (CARET , CHTBL(1,  95)), (USCORE, CHTBL(1,  96))
  711.       EQUIVALENCE (ACCENT, CHTBL(1,  97)), (ALOWER, CHTBL(1,  98))
  712.      1          , (BLOWER, CHTBL(1,  99)), (CLOWER, CHTBL(1, 100))
  713.      2          , (DLOWER, CHTBL(1, 101)), (ELOWER, CHTBL(1, 102))
  714.      3          , (FLOWER, CHTBL(1, 103)), (GLOWER, CHTBL(1, 104))
  715.      4          , (HLOWER, CHTBL(1, 105)), (ILOWER, CHTBL(1, 106))
  716.      5          , (JLOWER, CHTBL(1, 107)), (KLOWER, CHTBL(1, 108))
  717.      6          , (LLOWER, CHTBL(1, 109)), (MLOWER, CHTBL(1, 110))
  718.      7          , (NLOWER, CHTBL(1, 111)), (OLOWER, CHTBL(1, 112))
  719.      8          , (PLOWER, CHTBL(1, 113)), (QLOWER, CHTBL(1, 114))
  720.      9          , (RLOWER, CHTBL(1, 115)), (SLOWER, CHTBL(1, 116))
  721.      A          , (TLOWER, CHTBL(1, 117)), (ULOWER, CHTBL(1, 118))
  722.      B          , (VLOWER, CHTBL(1, 119)), (WLOWER, CHTBL(1, 120))
  723.      C          , (XLOWER, CHTBL(1, 121)), (YLOWER, CHTBL(1, 122))
  724.      D          , (ZLOWER, CHTBL(1, 123)), (LBRACE, CHTBL(1, 124))
  725.      E          , (ORSIGN, CHTBL(1, 125)), (RBRACE, CHTBL(1, 126))
  726.      F          , (TILDE , CHTBL(1, 127)), (SPC127, CHTBL(1, 128))
  727. C
  728.       COMMON /GRCS02/ CINDX1, CINDX2, CHTBL
  729. C
  730.       DATA CINDX1 /1/
  731.       DATA CINDX2 /0/
  732. C
  733.       DATA SPCH00 /07, 34, 37, 67, 61, 01, 07, 37, 00, 00
  734.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  735.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  736.       DATA SPCH01 /11, 34, 37, 47, 65, 63, 41, 21, 03, 05
  737.      1           , 27, 37, 00, 00, 00, 00, 00, 00, 00, 00
  738.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  739.       DATA SPCH02 /07, 34, 37, 64, 61, 01, 04, 37, 00, 00
  740.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  741.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  742.       DATA SPCH03 /02, 04, 64, 02, 37, 31, 00, 00, 00, 00
  743.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  744.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  745.       DATA SPCH04 /02, 01, 67, 02, 07, 61, 00, 00, 00, 00
  746.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  747.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  748.       DATA SPCH05 /06, 34, 37, 64, 31, 04, 37, 00, 00, 00
  749.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  750.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  751.       DATA SPCH06 /05, 31, 37, 64, 04, 37, 00, 00, 00, 00
  752.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  753.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  754.       DATA SPCH07 /04, 01, 67, 07, 61, 00, 00, 00, 00, 00
  755.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  756.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  757.       DATA SPCH08 /04, 07, 67, 01, 61, 02, 14, 54, 00, 00
  758.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  759.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  760.       DATA SPCH09 /03, 07, 34, 67, 02, 34, 31, 00, 00, 00
  761.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  762.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  763.       DATA SPCH10 /06, 61, 52, 56, 16, 12, 52, 02, 01, 12
  764.      1           , 02, 07, 16, 02, 67, 34, 00, 00, 00, 00
  765.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  766.       DATA SPCH11 /02, 01, 67, 02, 07, 61, 02, 04, 64, 02
  767.      1           , 37, 31, 00, 00, 00, 00, 00, 00, 00, 00
  768.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  769.       DATA SPCH12 /05, 01, 67, 07, 61, 01, 00, 00, 00, 00
  770.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  771.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  772.       DATA SPCH13 /02, 24, 44, 02, 37, 31, 00, 00, 00, 00
  773.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  774.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  775.       DATA SPCH14 /02, 07, 67, 02, 01, 61, 05, 31, 64, 37
  776.      1           , 04, 31, 01, 34, 00, 00, 00, 00, 00, 00
  777.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  778.       DATA SPCH15 /07, 23, 43, 44, 24, 25, 45, 44, 02, 35
  779.      1           , 33, 02, 23, 24, 00, 00, 00, 00, 00, 00
  780.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  781.       DATA SPCH16 /27, 01, 61, 62, 02, 03, 63, 64, 04, 05
  782.      1           , 65, 66, 06, 07, 67, 61, 51, 57, 47, 41
  783.      2           , 31, 37, 27, 21, 11, 17, 07, 01, 00, 00/
  784.       DATA SPCH17 /14, 21, 41, 52, 12, 03, 63, 64, 04, 05
  785.      1           , 65, 56, 16, 27, 47, 14, 03, 05, 16, 12
  786.      2           , 21, 27, 37, 31, 41, 47, 56, 52, 63, 65/
  787.       DATA SPCH18 /12, 31, 42, 22, 13, 53, 64, 04, 15, 55
  788.      1           , 46, 26, 37, 12, 64, 55, 53, 42, 46, 37
  789.      2           , 31, 22, 26, 15, 13, 04, 00, 00, 00, 00/
  790.       DATA SPCH19 /09, 26, 15, 13, 22, 42, 53, 55, 46, 26
  791.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  792.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  793.       DATA SPCH20 /09, 27, 05, 03, 21, 41, 63, 65, 47, 27
  794.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  795.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  796.       DATA SPCH21 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  797.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  798.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  799.       DATA SPCH22 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  800.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  801.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  802.       DATA SPCH23 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  803.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  804.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  805.       DATA SPCH24 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  806.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  807.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  808.       DATA SPCH25 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  809.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  810.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  811.       DATA SPCH26 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  812.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  813.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  814.       DATA SPCH27 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  815.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  816.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  817.       DATA SPCH28 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  818.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  819.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  820.       DATA SPCH29 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  821.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  822.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  823.       DATA SPCH30 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  824.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  825.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  826.       DATA SPCH31 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  827.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  828.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  829.       DATA SPACE  /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  830.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  831.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  832.       DATA EXCLAM /02, 38, 33, 01, 30, 00, 00, 00, 00, 00
  833.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  834.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  835.       DATA QUOTE  /02, 28, 26, 02, 48, 46, 00, 00, 00, 00
  836.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  837.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  838.       DATA POUND  /02, 10, 18, 02, 58, 50, 02, 62, 02, 02
  839.      1           , 06, 66, 00, 00, 00, 00, 00, 00, 00, 00
  840.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  841.       DATA DOLLAR /10, 01, 51, 62, 63, 54, 14, 05, 06, 17
  842.      1           , 67, 02, 38, 30, 00, 00, 00, 00, 00, 00
  843.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  844.       DATA PERCNT /05, 07, 18, 27, 16, 07, 02, 01, 67, 05
  845.      1           , 50, 61, 52, 41, 50, 00, 00, 00, 00, 00
  846.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  847.       DATA AMPERS /11, 60, 06, 07, 18, 48, 46, 02, 01, 10
  848.      1           , 30, 63, 00, 00, 00, 00, 00, 00, 00, 00
  849.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  850.       DATA APOSTR /06, 24, 46, 48, 38, 37, 47, 00, 00, 00
  851.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  852.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  853.       DATA LPAREN /04, 40, 22, 26, 48, 00, 00, 00, 00, 00
  854.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  855.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  856.       DATA RPAREN /04, 20, 42, 46, 28, 00, 00, 00, 00, 00
  857.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  858.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  859.       DATA ASTER  /02, 01, 67, 02, 07, 61, 02, 04, 64, 02
  860.      1           , 37, 31, 00, 00, 00, 00, 00, 00, 00, 00
  861.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  862.       DATA PLUS   /02, 14, 54, 02, 36, 32, 00, 00, 00, 00
  863.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  864.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  865.       DATA COMMA  /06, 20, 42, 44, 34, 33, 43, 00, 00, 00
  866.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  867.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  868.       DATA MINUS  /02, 14, 54, 00, 00, 00, 00, 00, 00, 00
  869.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  870.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  871.       DATA PERIOD /05, 20, 30, 31, 21, 20, 00, 00, 00, 00
  872.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  873.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  874.       DATA SLASH  /02, 01, 67, 00, 00, 00, 00, 00, 00, 00
  875.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  876.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  877.       DATA ZERO   /09, 10, 50, 61, 67, 58, 18, 07, 01, 10
  878.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  879.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  880.       DATA ONE    /02, 10, 50, 03, 30, 38, 16, 00, 00, 00
  881.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  882.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  883.       DATA TWO    /10, 07, 18, 58, 67, 65, 54, 24, 02, 00
  884.      1           , 60, 00, 00, 00, 00, 00, 00, 00, 00, 00
  885.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  886.       DATA THREE  /07, 07, 18, 58, 67, 65, 54, 34, 06, 54
  887.      1           , 63, 61, 50, 10, 01, 00, 00, 00, 00, 00
  888.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  889.       DATA FOUR   /05, 50, 58, 03, 02, 72, 00, 00, 00, 00
  890.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  891.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  892.       DATA FIVE   /10, 01, 10, 40, 62, 63, 45, 05, 08, 68
  893.      1           , 67, 00, 00, 00, 00, 00, 00, 00, 00, 00
  894.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  895.       DATA SIX    /11, 04, 54, 63, 61, 50, 10, 01, 06, 28
  896.      1           , 58, 67, 00, 00, 00, 00, 00, 00, 00, 00
  897.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  898.       DATA SEVEN  /06, 20, 23, 67, 68, 08, 07, 00, 00, 00
  899.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  900.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  901.       DATA EIGHT  /16, 14, 03, 01, 10, 50, 61, 63, 54, 14
  902.      1           , 05, 07, 18, 58, 67, 65, 54, 00, 00, 00
  903.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  904.       DATA NINE   /11, 01, 10, 40, 62, 67, 58, 18, 07, 05
  905.      1           , 14, 64, 00, 00, 00, 00, 00, 00, 00, 00
  906.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  907.       DATA COLON  /05, 22, 32, 33, 23, 22, 05, 26, 36, 37
  908.      1           , 27, 26, 00, 00, 00, 00, 00, 00, 00, 00
  909.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  910.       DATA SEMICO /06, 10, 32, 34, 24, 23, 33, 05, 26, 36
  911.      1           , 37, 27, 26, 00, 00, 00, 00, 00, 00, 00
  912.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  913.       DATA LESS   /03, 50, 14, 58, 00, 00, 00, 00, 00, 00
  914.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  915.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  916.       DATA EQUALS /02, 12, 52, 02, 16, 56, 00, 00, 00, 00
  917.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  918.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  919.       DATA GREATR /03, 10, 54, 18, 00, 00, 00, 00, 00, 00
  920.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  921.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  922.       DATA QUESTN /07, 06, 07, 18, 58, 67, 34, 33, 01, 31
  923.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  924.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  925.       DATA ATSIGN /13, 54, 45, 34, 43, 54, 64, 66, 48, 28
  926.      1           , 06, 02, 20, 50, 00, 00, 00, 00, 00, 00
  927.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  928.       DATA AUPPER /05, 00, 05, 38, 65, 60, 02, 03, 63, 00
  929.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  930.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  931.       DATA BUPPER /06, 00, 50, 61, 63, 54, 14, 05, 08, 58
  932.      1           , 67, 65, 54, 02, 18, 10, 00, 00, 00, 00
  933.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  934.       DATA CUPPER /08, 67, 58, 28, 06, 02, 20, 50, 61, 00
  935.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  936.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  937.       DATA DUPPER /06, 00, 40, 62, 66, 48, 08, 02, 18, 10
  938.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  939.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  940.       DATA EUPPER /04, 60, 00, 08, 68, 02, 34, 04, 00, 00
  941.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  942.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  943.       DATA FUPPER /03, 00, 08, 68, 02, 34, 04, 00, 00, 00
  944.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  945.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  946.       DATA GUPPER /10, 67, 58, 28, 06, 02, 20, 50, 61, 64
  947.      1           , 44, 00, 00, 00, 00, 00, 00, 00, 00, 00
  948.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  949.       DATA HUPPER /02, 00, 08, 02, 60, 68, 02, 04, 64, 00
  950.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  951.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  952.       DATA IUPPER /02, 10, 50, 02, 30, 38, 02, 18, 58, 00
  953.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  954.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  955.       DATA JUPPER /05, 01, 10, 20, 31, 38, 02, 18, 58, 00
  956.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  957.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  958.       DATA KUPPER /02, 00, 08, 02, 68, 02, 02, 24, 60, 00
  959.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  960.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  961.       DATA LUPPER /03, 08, 00, 60, 00, 00, 00, 00, 00, 00
  962.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  963.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  964.       DATA MUPPER /05, 00, 08, 35, 68, 60, 00, 00, 00, 00
  965.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  966.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  967.       DATA NUPPER /02, 00, 08, 02, 07, 61, 02, 60, 68, 00
  968.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  969.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  970.       DATA OUPPER /09, 20, 40, 62, 66, 48, 28, 06, 02, 20
  971.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  972.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  973.       DATA PUPPER /07, 00, 08, 58, 67, 66, 55, 05, 00, 00
  974.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  975.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  976.       DATA QUPPER /09, 20, 40, 62, 66, 48, 28, 06, 02, 20
  977.      1           , 02, 33, 60, 00, 00, 00, 00, 00, 00, 00
  978.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  979.       DATA RUPPER /07, 00, 08, 58, 67, 66, 55, 05, 02, 15
  980.      1           , 60, 00, 00, 00, 00, 00, 00, 00, 00, 00
  981.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  982.       DATA SUPPER /12, 01, 10, 50, 61, 63, 54, 14, 05, 07
  983.      1           , 18, 58, 67, 00, 00, 00, 00, 00, 00, 00
  984.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  985.       DATA TUPPER /02, 30, 38, 02, 08, 68, 00, 00, 00, 00
  986.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  987.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  988.       DATA UUPPER /06, 08, 01, 10, 50, 61, 68, 00, 00, 00
  989.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  990.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  991.       DATA VUPPER /05, 08, 03, 30, 63, 68, 00, 00, 00, 00
  992.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  993.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  994.       DATA WUPPER /05, 08, 00, 33, 60, 68, 00, 00, 00, 00
  995.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  996.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  997.       DATA XUPPER /04, 00, 01, 67, 68, 04, 08, 07, 61, 60
  998.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  999.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1000.       DATA YUPPER /03, 08, 35, 68, 02, 35, 30, 00, 00, 00
  1001.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1002.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1003.       DATA ZUPPER /06, 08, 68, 67, 01, 00, 60, 00, 00, 00
  1004.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1005.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1006.       DATA LBRACK /04, 40, 20, 28, 48, 00, 00, 00, 00, 00
  1007.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1008.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1009.       DATA BKSLSH /02, 07, 61, 00, 00, 00, 00, 00, 00, 00
  1010.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1011.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1012.       DATA RBRACK /04, 20, 40, 48, 28, 00, 00, 00, 00, 00
  1013.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1014.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1015.       DATA CARET  /03, 05, 38, 65, 00, 00, 00, 00, 00, 00
  1016.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1017.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1018.       DATA USCORE /02,-01,-61, 00, 00, 00, 00, 00, 00, 00
  1019.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1020.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1021.       DATA ACCENT /05, 27, 28, 38, 37, 55, 00, 00, 00, 00
  1022.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1023.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1024.       DATA ALOWER /05, 06, 26, 35, 31, 40, 07, 31, 20, 10
  1025.      1           , 01, 02, 13, 33, 00, 00, 00, 00, 00, 00
  1026.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1027.       DATA BLOWER /02, 08, 00, 08, 02, 20, 30, 41, 44, 35
  1028.      1           , 25, 03, 00, 00, 00, 00, 00, 00, 00, 00
  1029.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1030.       DATA CLOWER /08, 41, 30, 10, 01, 04, 15, 35, 44, 00
  1031.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1032.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1033.       DATA DLOWER /02, 48, 40, 08, 42, 20, 10, 01, 04, 15
  1034.      1           , 25, 43, 00, 00, 00, 00, 00, 00, 00, 00
  1035.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1036.       DATA ELOWER /10, 40, 10, 01, 04, 15, 35, 44, 43, 32
  1037.      1           , 02, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1038.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1039.       DATA FLOWER /04, 10, 17, 28, 37, 02, 04, 24, 00, 00
  1040.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1041.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1042.       DATA GLOWER /11, 40, 10, 01, 04, 15, 35, 44,-41,-23
  1043.      1           ,-13,-02, 00, 00, 00, 00, 00, 00, 00, 00
  1044.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1045.       DATA HLOWER /02, 00, 08, 05, 03, 25, 35, 44, 40, 00
  1046.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1047.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1048.       DATA ILOWER /01, 37, 03, 25, 35, 30, 02, 20, 40, 00
  1049.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1050.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1051.       DATA JLOWER /01, 37, 06, 35,-32,-23,-13,-02,-01, 00
  1052.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1053.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1054.       DATA KLOWER /02, 08, 00, 02, 01, 45, 03, 40, 22, 23
  1055.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1056.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1057.       DATA LLOWER /02, 20, 40, 03, 30, 38, 28, 00, 00, 00
  1058.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1059.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1060.       DATA MLOWER /06, 00, 04, 15, 25, 34, 30, 05, 34, 45
  1061.      1           , 55, 64, 60, 00, 00, 00, 00, 00, 00, 00
  1062.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1063.       DATA NLOWER /02, 00, 05, 05, 03, 25, 35, 44, 40, 00
  1064.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1065.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1066.       DATA OLOWER /09, 01, 04, 15, 35, 44, 41, 30, 10, 01
  1067.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1068.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1069.       DATA PLOWER /02,-03, 05, 08, 03, 25, 35, 44, 41, 30
  1070.      1           , 20, 02, 00, 00, 00, 00, 00, 00, 00, 00
  1071.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1072.       DATA QLOWER /02,-43, 45, 08, 43, 25, 15, 04, 01, 10
  1073.      1           , 20, 42, 00, 00, 00, 00, 00, 00, 00, 00
  1074.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1075.       DATA RLOWER /02, 00, 05, 04, 03, 25, 35, 44, 00, 00
  1076.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1077.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1078.       DATA SLOWER /09, 00, 30, 41, 42, 33, 13, 04, 15, 45
  1079.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1080.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1081.       DATA TLOWER /02, 06, 26, 05, 18, 11, 20, 30, 41, 00
  1082.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1083.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1084.       DATA ULOWER /05, 05, 01, 10, 20, 42, 02, 40, 45, 00
  1085.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1086.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1087.       DATA VLOWER /05, 05, 02, 20, 42, 45, 00, 00, 00, 00
  1088.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1089.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1090.       DATA WLOWER /06, 05, 01, 10, 20, 31, 35, 05, 31, 40
  1091.      1           , 50, 61, 65, 00, 00, 00, 00, 00, 00, 00
  1092.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1093.       DATA XLOWER /02, 00, 55, 02, 05, 50, 00, 00, 00, 00
  1094.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1095.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1096.       DATA YLOWER /05, 05, 01, 10, 30, 41, 05, 45,-42,-33
  1097.      1           ,-23,-12, 00, 00, 00, 00, 00, 00, 00, 00
  1098.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1099.       DATA ZLOWER /04, 05, 55, 00, 50, 00, 00, 00, 00, 00
  1100.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1101.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1102.       DATA LBRACE /06, 40, 30, 21, 23, 14, 04, 05, 14, 25
  1103.      1           , 27, 38, 48, 00, 00, 00, 00, 00, 00, 00
  1104.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1105.       DATA ORSIGN /02, 30, 38, 00, 00, 00, 00, 00, 00, 00
  1106.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1107.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1108.       DATA RBRACE /06, 20, 30, 41, 43, 54, 64, 05, 54, 45
  1109.      1           , 47, 38, 28, 00, 00, 00, 00, 00, 00, 00
  1110.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1111.       DATA TILDE  /04, 06, 28, 46, 68, 00, 00, 00, 00, 00
  1112.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1113.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1114.       DATA SPC127 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1115.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1116.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1117.       END
  1118. C*GRDOT0 -- draw a dot
  1119. C+
  1120.       SUBROUTINE GRDOT0 (X,Y)
  1121. C
  1122. C GRPCKG (internal routine): Draw a single dot (pixel) at a specified
  1123. C location.
  1124. C
  1125. C Arguments:
  1126. C
  1127. C X, Y (real, input): absolute device coordinates of the dot (these
  1128. C       are rounded to the nearest integer by GRDOT0).
  1129. C--
  1130. C (1-Jun-1984)
  1131. C 22-Oct-1984 - rewrite [TJP].
  1132. C 29-Jan-1985 - add HP2648 device [KS/TJP].
  1133. C  5-Aug-1986 - add GREXEC support [AFT].
  1134. C 21-Feb-1987 - If needed, calls begin picture [AFT].
  1135. C-----------------------------------------------------------------------
  1136.       INCLUDE 'f77.GRPCKG1/IN'
  1137.       INTEGER  NBUF, LCHR
  1138.       REAL     X, Y, RBUF(6)
  1139.       CHARACTER CHR
  1140. C
  1141. C (X,Y) is the new current position.
  1142. C
  1143.       GRXPRE(GRCIDE) = X
  1144.       GRYPRE(GRCIDE) = Y
  1145. C
  1146. C Check window.
  1147. C
  1148.       IF (X .LT. GRXMIN(GRCIDE)) RETURN
  1149.       IF (X .GT. GRXMAX(GRCIDE)) RETURN
  1150.       IF (Y .LT. GRYMIN(GRCIDE)) RETURN
  1151.       IF (Y .GT. GRYMAX(GRCIDE)) RETURN
  1152. C
  1153. C Begin picture if necessary.
  1154. C
  1155.       IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  1156. C
  1157. C If a "thick pen" is to be simulated, use the line-drawing routines
  1158. C instead.
  1159. C
  1160.       IF (GRWIDT(GRCIDE).GT.1) THEN
  1161.           CALL GRLIN3(X,Y,X,Y)
  1162.       ELSE
  1163.           RBUF(1)=X
  1164.           RBUF(2)=Y
  1165.           NBUF=2
  1166.           CALL GREXEC(GRGTYP,13,RBUF,NBUF,CHR,LCHR)
  1167.       END IF
  1168.       END
  1169. C*GRDTYP -- decode graphics device type string
  1170. C+
  1171.       INTEGER FUNCTION GRDTYP (TEXT)
  1172. C
  1173. C GRPCKG (internal routine): determine graphics device type code from
  1174. C type name. It compares the argument with the table of known device
  1175. C types in common.
  1176. C
  1177. C Argument:
  1178. C
  1179. C TEXT (input, character): device type name, eg 'PRINTRONIX'; the name
  1180. C       may be abbreviated to uniqueness.
  1181. C
  1182. C Returns:
  1183. C
  1184. C GRDTYP (integer): the device type code, in the range 1 to
  1185. C       GRTMAX, zero if the type name is not recognised, or -1
  1186. C       if the type name is ambiguous.
  1187. C--
  1188. C 27-Dec-1984 - rewrite so that is doesn't have to be modified for
  1189. C               new devices [TJP].
  1190. C  5-Aug-1986 - add GREXEC support [AFT].
  1191. C 10-Nov-1995 - ignore drivers that report no device type [TJP].
  1192. C 30-Aug-1996 - check for an exact match; indicate if type is
  1193. C               ambiguous [TJP].
  1194. C-----------------------------------------------------------------------
  1195.       INCLUDE 'f77.GRPCKG1/IN'
  1196.       CHARACTER*(*) TEXT
  1197.       INTEGER  CODE, I, L, MATCH
  1198.       REAL     RBUF(6)
  1199.       INTEGER NDEV,NBUF,LCHR
  1200.       INTEGER GRTRIM
  1201.       CHARACTER*32 CHR
  1202. C
  1203.       GRDTYP = 0
  1204.       L = GRTRIM(TEXT)
  1205.       IF (L.LT.1) RETURN
  1206.       MATCH = 0
  1207.       CODE = 0
  1208.       CALL GREXEC(0,0,RBUF,NBUF,CHR,LCHR)
  1209.       NDEV=NINT(RBUF(1))
  1210.       DO 30 I=1,NDEV
  1211.          CALL GREXEC(I, 1,RBUF,NBUF,CHR,LCHR)
  1212.          IF (LCHR.GT.0) THEN
  1213.             IF(TEXT(1:L).EQ.CHR(1:L)) THEN
  1214.                IF (CHR(L+1:L+1).EQ.' ') THEN
  1215. C                 -- exact match
  1216.                   GRDTYP = I
  1217.                   GRGTYP = GRDTYP
  1218.                   RETURN
  1219.                ELSE
  1220.                   MATCH = MATCH+1
  1221.                   CODE = I
  1222.                END IF
  1223.             END IF
  1224.          END IF
  1225.    30 CONTINUE
  1226.       IF (MATCH.EQ.0) THEN
  1227. C        -- no match
  1228.          GRDTYP = 0
  1229.       ELSE IF (MATCH.EQ.1) THEN
  1230.          GRDTYP = CODE
  1231.          GRGTYP = GRDTYP
  1232.       ELSE
  1233.          GRDTYP = -1
  1234.       END IF
  1235. C
  1236.       END
  1237. C*GREPIC -- end picture
  1238. C+
  1239.       SUBROUTINE GREPIC
  1240. C
  1241. C GRPCKG: End the current picture.
  1242. C
  1243. C Arguments: none.
  1244. C--
  1245. C 17-Nov-1994 - [TJP].
  1246. C-----------------------------------------------------------------------
  1247.       INCLUDE 'f77.GRPCKG1/IN'
  1248.       REAL    RBUF(6)
  1249.       INTEGER NBUF,LCHR
  1250.       CHARACTER CHR
  1251. C
  1252. C Check a plot is open.
  1253. C
  1254.       IF (GRCIDE.LT.1) RETURN
  1255. C
  1256. C End picture.
  1257. C
  1258.       IF (GRPLTD(GRCIDE)) THEN
  1259.             RBUF(1) = 1.
  1260.             NBUF = 1
  1261.             CALL GREXEC(GRGTYP,14,RBUF,NBUF,CHR,LCHR)
  1262.       END IF
  1263.       GRPLTD(GRCIDE) = .FALSE.
  1264. C
  1265.       END
  1266. C*GRESC -- escape routine
  1267. C+
  1268.       SUBROUTINE GRESC (TEXT)
  1269. C
  1270. C GRPCKG: "Escape" routine. The specified text is sent directly to the
  1271. C selected graphics device, with no interpretation by GRPCKG. This
  1272. C routine must be used with care; e.g., the programmer needs to know
  1273. C the device type of the currently selected device, and the instructions
  1274. C that that device can accept.
  1275. C
  1276. C Arguments: none.
  1277. C  TEXT (input, character*(*)):  text to be sent to the device.
  1278. C
  1279. C 15-May-1985 - new routine [TJP].
  1280. C 26-May-1987 - add GREXEC support [TJP].
  1281. C 19-Dec-1988 - start new page if necessary [TJP].
  1282. C-----------------------------------------------------------------------
  1283.       INCLUDE 'f77.GRPCKG1/IN'
  1284.       CHARACTER*(*) TEXT
  1285.       REAL RBUF
  1286.       INTEGER NBUF
  1287. C
  1288. C If no device is currently selected, do nothing.
  1289. C
  1290.       IF (GRCIDE.GT.0) THEN
  1291.           IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  1292.           NBUF = 0
  1293.           CALL GREXEC(GRGTYP,23,RBUF,NBUF,TEXT,LEN(TEXT))
  1294.       END IF
  1295.       END
  1296.  
  1297. C*GRETXT -- erase text from graphics screen
  1298. C+
  1299.       SUBROUTINE GRETXT
  1300. C
  1301. C GRPCKG: Erase the text screen.  Some graphics devices have
  1302. C two superimposed view surfaces, of which one is used for graphics and
  1303. C the other for alphanumeric text.  This routine erases the text
  1304. C view surface without affecting the graphics view surface. It does
  1305. C nothing if there is no text view surface associated with the device.
  1306. C
  1307. C Arguments: none.
  1308. C--
  1309. C (1-Feb-1983)
  1310. C 16-Oct-1984 - add ID100 device [RSS/TJP].
  1311. C 29-Jan-1985 - add HP2648 device [KS/TJP].
  1312. C  5-Aug-1986 - add GREXEC support [AFT].
  1313. C 11-Jun-1987 - remove built-in devices [TJP].
  1314. C-----------------------------------------------------------------------
  1315.       INCLUDE 'f77.GRPCKG1/IN'
  1316.       CHARACTER*1   CHR
  1317.       REAL    RBUF(6)
  1318.       INTEGER NBUF,LCHR
  1319. C
  1320.       IF (GRCIDE.GE.1) THEN
  1321.           CALL GREXEC(GRGTYP,18,RBUF,NBUF,CHR,LCHR)
  1322.       END IF
  1323. C
  1324.       END
  1325. C*GRFA -- fill area (polygon)
  1326. C+
  1327.       SUBROUTINE GRFA (N,PX,PY)
  1328.       INTEGER N
  1329.       REAL PX(*), PY(*)
  1330. C
  1331. C GRPCKG: FILL AREA: fill a polygon with solid color.  The polygon
  1332. C is defined by the (x,y) world coordinates of its N vertices.  If
  1333. C this is not a function supported by the device, shading is
  1334. C accomplished by drawing horizontal lines spaced by 1 pixel.  By
  1335. C selecting color index 0, the interior of the polygon can be erased
  1336. C on devices which permit it.  The polygon need not be convex, but if
  1337. C it is re-entrant (i.e., edges intersect other than at the vertices),
  1338. C it may not be obvious which regions are "inside" the polygon.  The
  1339. C following rule is applied: for a given point, create a straight line
  1340. C starting at the point and going to infinity. If the number of
  1341. C intersections between the straight line and the polygon is odd, the
  1342. C point is within the polygon; otherwise it is outside. If the
  1343. C straight line passes a polygon vertex tangentially, the
  1344. C intersection  count is not affected. The only attribute which applies
  1345. C to FILL AREA is color index: line-width and line-style are ignored.
  1346. C There is a limitation on the complexity of the polygon: GFA will
  1347. C fail if any horizontal line intersects more than 32 edges of the
  1348. C polygon.
  1349. C
  1350. C Arguments:
  1351. C
  1352. C N (input, integer): the number of vertices of the polygon (at least
  1353. C       3).
  1354. C PX, PY (input, real arrays, dimension at least N): world coordinates
  1355. C       of the N vertices of the polygon.
  1356. C--
  1357. C 16-Jul-1984 - [TJP].
  1358. C  5-Aug-1986 - add GREXEC support [AFT].
  1359. C 21-Feb-1987 - If needed, calls begin picture [AFT].
  1360. C  7-Sep-1994 - avoid driver call for capabilities [TJP].
  1361. C  1-May-1995 - fixed bug for re-entrant polygons, and optimized code
  1362. C               [A.F.Carman].
  1363. C 18-Oct-1995 - fixed bug: emulated fill failed for reversed y-axis
  1364. C               [S.C.Allendorf/TJP].
  1365. C  4-Dec-1995 - remove use of real variable as do-loop variable [TJP].
  1366. C 20-Mar-1996 - use another do loop 40 to avoid gaps between adjacent
  1367. C               polygons [RS]
  1368. C-----------------------------------------------------------------------
  1369.       INCLUDE 'f77.GRPCKG1/IN'
  1370.       INTEGER MAXSEC
  1371.       PARAMETER (MAXSEC=32)
  1372.       INTEGER I, J, NSECT, LW, LS, NBUF, LCHR, LINE
  1373.       REAL    RBUF(6)
  1374.       CHARACTER*32 CHR
  1375.       REAL    X(MAXSEC), Y, YMIN, YMAX, DY, YD, TEMP, S1, S2, T1, T2
  1376.       LOGICAL FORWD
  1377. C
  1378.       IF (GRCIDE.LT.1) RETURN
  1379.       IF (N.LT.3) THEN
  1380.           CALL GRWARN('GRFA - polygon has < 3 vertices.')
  1381.           RETURN
  1382.       END IF
  1383. C
  1384. C Devices with polygon fill capability.
  1385. C
  1386.       IF(GRGCAP(GRCIDE)(4:4).EQ.'A') THEN
  1387.          IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  1388.          RBUF(1) = N
  1389.          CALL GREXEC(GRGTYP,20,RBUF,NBUF,CHR,LCHR)
  1390.          DO 10 I=1,N
  1391.             RBUF(1) = PX(I)*GRXSCL(GRCIDE) + GRXORG(GRCIDE)
  1392.             RBUF(2) = PY(I)*GRYSCL(GRCIDE) + GRYORG(GRCIDE)
  1393.             CALL GREXEC(GRGTYP,20,RBUF,NBUF,CHR,LCHR)
  1394.  10      CONTINUE
  1395.          RETURN
  1396.       END IF
  1397. C
  1398. C For other devices fill area is simulated.
  1399. C
  1400. C Save attributes.
  1401. C
  1402.       CALL GRQLS(LS)
  1403.       CALL GRQLW(LW)
  1404.       CALL GRSLS(1)
  1405.       CALL GRSLW(1)
  1406. C
  1407. C Find range of raster-lines to be shaded.
  1408. C
  1409.       YMIN = PY(1)*GRYSCL(GRCIDE) + GRYORG(GRCIDE)
  1410.       YMAX = YMIN
  1411.       DO 20 I=2,N
  1412.          YD = PY(I)*GRYSCL(GRCIDE) + GRYORG(GRCIDE)
  1413.          YMIN = MIN(YMIN,YD)
  1414.          YMAX = MAX(YMAX,YD)
  1415.  20   CONTINUE
  1416.       CALL GREXEC(GRGTYP, 3,RBUF,NBUF,CHR,LCHR)
  1417.       DY = ABS(RBUF(3))
  1418. C
  1419. C Find intersections of edges with current raster line.
  1420. C
  1421.       FORWD = .TRUE.
  1422.       S1 = PX(N)*GRXSCL(GRCIDE) + GRXORG(GRCIDE)
  1423.       T1 = PY(N)*GRYSCL(GRCIDE) + GRYORG(GRCIDE)
  1424. C
  1425.       DO 40 LINE = NINT(YMIN/DY),NINT(YMAX/DY)
  1426.          Y = LINE * DY
  1427.          NSECT = 0
  1428.          DO 30 I=1,N
  1429.             S2 = PX(I)*GRXSCL(GRCIDE) + GRXORG(GRCIDE)
  1430.             T2 = PY(I)*GRYSCL(GRCIDE) + GRYORG(GRCIDE)
  1431.             IF ((T1.LT.Y .AND. Y.LE.T2).OR.
  1432.      :          (T1.GE.Y .AND. Y.GT.T2)) THEN
  1433.                NSECT = NSECT+1
  1434.                IF (NSECT.GT.MAXSEC) THEN
  1435.                   CALL GRWARN('GRFA - polygon is too complex.')
  1436.                   RETURN
  1437.                END IF
  1438.                X(NSECT)=(S1+(S2-S1)*((Y-T1)/(T2-T1)))
  1439.             END IF
  1440.             S1 = S2
  1441.             T1 = T2
  1442.  30      CONTINUE
  1443. C
  1444. C Sort the intersections into increasing x order.
  1445. C
  1446.          DO 34 I=2,NSECT
  1447.             DO 32 J=1,I
  1448.                IF (X(J).GT.X(I)) THEN
  1449.                   TEMP = X(J)
  1450.                   X(J) = X(I)
  1451.                   X(I) = TEMP
  1452.                END IF
  1453.  32         CONTINUE
  1454.  34      CONTINUE
  1455. C
  1456. C Draw the horizontal line-segments.
  1457. C
  1458.          GRYPRE(GRCIDE) = Y
  1459.          IF (FORWD) THEN
  1460.             DO 36 I=1,NSECT-1,2
  1461.                GRXPRE(GRCIDE) = X(I)
  1462.                CALL GRLIN0(X(I+1),Y)
  1463.  36         CONTINUE
  1464.             FORWD = .FALSE.
  1465.          ELSE
  1466.             DO 38 I=NSECT,2,-2
  1467.                GRXPRE(GRCIDE) = X(I)
  1468.                CALL GRLIN0(X(I-1),Y)
  1469.  38         CONTINUE
  1470.             FORWD = .TRUE.
  1471.          END IF
  1472.  40   CONTINUE
  1473. C
  1474. C Restore attributes.
  1475. C
  1476.       CALL GRSLS(LS)
  1477.       CALL GRSLW(LW)
  1478.       END
  1479. C*GRFAO - format character string containing integers
  1480. C+
  1481.       SUBROUTINE GRFAO (FORMAT, L, STR, V1, V2, V3, V4)
  1482.       CHARACTER*(*) FORMAT
  1483.       INTEGER L
  1484.       CHARACTER*(*) STR
  1485.       INTEGER V1, V2, V3, V4
  1486. C
  1487. C The input string FORMAT is copied to the output string STR with
  1488. C the first occurrence of '#' replaced by the value of V1, the second
  1489. C by the value of V2, etc.  The length of the resulting string is 
  1490. C returned in L.
  1491. C-----------------------------------------------------------------------
  1492.       INTEGER I,Q,VAL,GRITOC
  1493. C
  1494.       L = 0
  1495.       Q = 0
  1496.       DO 10 I=1,LEN(FORMAT)
  1497.           IF (L.GE.LEN(STR)) RETURN
  1498.           IF (FORMAT(I:I).NE.'#') THEN
  1499.               L = L+1
  1500.               STR(L:L) = FORMAT(I:I)
  1501.           ELSE
  1502.               Q = Q+1
  1503.               VAL = 0
  1504.               IF (Q.EQ.1) VAL = V1
  1505.               IF (Q.EQ.2) VAL = V2
  1506.               IF (Q.EQ.3) VAL = V3
  1507.               IF (Q.EQ.4) VAL = V4
  1508.               L = L + GRITOC(VAL, STR(L+1:))
  1509.           END IF
  1510.    10 CONTINUE
  1511. C-----------------------------------------------------------------------
  1512.       END
  1513. C*GRGFIL -- find data file
  1514. C+
  1515.       SUBROUTINE GRGFIL(TYPE, NAME)
  1516.       CHARACTER*(*) TYPE, NAME
  1517. C
  1518. C This routine encsapsulates the algorithm for finding the PGPLOT
  1519. C run-time data files.
  1520. C
  1521. C 1. The binary font file: try the following in order:
  1522. C     file specified by PGPLOT_FONT
  1523. C     file "grfont.dat" in directory specified by PGPLOT_DIR
  1524. C                       (with or without '/' appended)
  1525. C     file "grfont.dat" in directory /usr/local/pgplot/
  1526. C
  1527. C 2. The color-name database: try the following in order:
  1528. C     file specified by PGPLOT_RGB
  1529. C     file "rgb.txt" in directory specified by PGPLOT_DIR
  1530. C                       (with or without '/' appended)
  1531. C     file "rgb.txt" in directory /usr/local/pgplot/
  1532. C
  1533. C Arguments:
  1534. C  TYPE (input)  : either 'FONT' or 'RGB' to request the corresponding
  1535. C                  file.
  1536. C  NAME (output) : receives the file name.
  1537. C--
  1538. C  2-Dec-1994 - new routine [TJP].
  1539. C-----------------------------------------------------------------------
  1540.       CHARACTER*(*) DEFDIR, DEFFNT, DEFRGB
  1541.       PARAMETER  (DEFDIR='/usr/local/pgplot/')
  1542.       PARAMETER  (DEFFNT='grfont.dat')
  1543.       PARAMETER  (DEFRGB='rgb.txt')
  1544.       CHARACTER*255 FF
  1545.       CHARACTER*16 DEFLT
  1546.       INTEGER I, L, LD
  1547.       LOGICAL TEST, DEBUG
  1548. C
  1549. C Is debug output requested?
  1550. C
  1551.       CALL GRGENV('DEBUG', FF, L)
  1552.       DEBUG = L.GT.0
  1553. C
  1554. C Which file?
  1555. C
  1556.       IF (TYPE.EQ.'FONT') THEN
  1557.          DEFLT = DEFFNT
  1558.          LD = LEN(DEFFNT)
  1559.       ELSE IF (TYPE.EQ.'RGB') THEN
  1560.          DEFLT = DEFRGB
  1561.          LD = LEN(DEFRGB)
  1562.       ELSE
  1563.          CALL GRWARN('Internal error in routine GRGFIL')
  1564.       END IF
  1565. C
  1566. C Try each possibility in turn.
  1567. C
  1568.       DO 10 I=1,4
  1569.          IF (I.EQ.1) THEN
  1570.             CALL GRGENV(TYPE, FF, L)
  1571.          ELSE IF (I.EQ.2) THEN
  1572.             CALL GRGENV('DIR', FF, L)
  1573.             IF (L.GT.0) THEN
  1574.                FF(L+1:) = DEFLT
  1575.                L = L+LD
  1576.             END IF
  1577.          ELSE IF (I.EQ.3) THEN
  1578.             CALL GRGENV('DIR', FF, L)
  1579.             IF (L.GT.0) THEN
  1580.                FF(L+1:L+1) = '/'
  1581.                FF(L+2:) = DEFLT
  1582.                L = L+1+LD
  1583.             END IF
  1584.          ELSE IF (I.EQ.4) THEN
  1585.             FF = DEFDIR//DEFLT
  1586.             L = LEN(DEFDIR)+LD
  1587.          END IF
  1588.          IF (L.GT.0) THEN
  1589.             IF (DEBUG) THEN
  1590.                CALL GRWARN('Looking for '//FF(:L))
  1591.             END IF
  1592.             INQUIRE (FILE=FF(:L), EXIST=TEST)
  1593.             IF (TEST) THEN
  1594.                NAME = FF(:L)
  1595.                RETURN
  1596.             ELSE IF (DEBUG) THEN
  1597.                CALL GRWARN('WARNING: file not found')
  1598.             END IF
  1599.          END IF
  1600.  10   CONTINUE
  1601. C
  1602. C Failed to find the file.
  1603. C
  1604.       NAME = DEFLT
  1605. C-----------------------------------------------------------------------
  1606.       END
  1607. C*GRGRAY -- gray-scale map of a 2D data array
  1608. C+
  1609.       SUBROUTINE GRGRAY (A, IDIM, JDIM, I1, I2, J1, J2,
  1610.      1                   FG, BG, PA, MININD, MAXIND, MODE)
  1611.       INTEGER IDIM, JDIM, I1, I2, J1, J2, MININD, MAXIND, MODE
  1612.       REAL    A(IDIM,JDIM)
  1613.       REAL    FG, BG
  1614.       REAL    PA(6)
  1615. C
  1616. C This is a device-dependent support routine for PGGRAY.
  1617. C
  1618. C Draw gray-scale map of an array in current window. Array
  1619. C values between FG and BG are shaded in gray levels determined
  1620. C by linear interpolation. FG may be either less than or greater
  1621. C than BG.  Array values outside the range FG to BG are
  1622. C shaded black or white as appropriate.
  1623. C
  1624. C GRGRAY uses GRIMG0 on devices with enough color indices available.
  1625. C Note that it changes the color table to gray-scale.
  1626. C Otherwise in does a random dither with GRIMG3.
  1627. C
  1628. C Arguments:
  1629. C  A      (input)  : the array to be plotted.
  1630. C  IDIM   (input)  : the first dimension of array A.
  1631. C  JDIM   (input)  : the second dimension of array A.
  1632. C  I1, I2 (input)  : the inclusive range of the first index
  1633. C                    (I) to be plotted.
  1634. C  J1, J2 (input)  : the inclusive range of the second
  1635. C                    index (J) to be plotted.
  1636. C  FG     (input)  : the array value which is to appear in
  1637. C                    foreground color.
  1638. C  BG     (input)  : the array value which is to appear in
  1639. C                    background color.
  1640. C  PA     (input)  : transformation matrix between array grid and
  1641. C                    device coordinates (see GRCONT).
  1642. C  MODE   (input)  : transfer function.
  1643. C--
  1644. C 12-Dec-1986 - Speed up plotting [J. Biretta].
  1645. C  3-Apr-1987 - Add special code for /PS, /VPS, /GR.
  1646. C  2-Sep-1987 - Adapted from PGGRAY [TJP].
  1647. C  1-Dec-1988 - Put random-number generator inline [TJP].
  1648. C  3-Apr-1989 - Use "line of pixels" primitive where available [TJP].
  1649. C  6-Sep-1989 - Changes for standard Fortran-77 [TJP].
  1650. C 19-Jan-1990 - Add special code for /CPS, /VCPS [DLM]
  1651. C  3-Sep-1992 - Add special code for NULL device [TJP].
  1652. C 25-Nov-1992 - Add special code for /NEXT [AFT].
  1653. C 17-Mar-1994 - Scale in device coordinates [TJP].
  1654. C 31-Aug-1994 - use GRIMG0 when appropriate [TJP].
  1655. C  7-Sep-1994 - speed up random dither [TJP].
  1656. C  8-Feb-1995 - use color ramp based on color indices 0 and 1 [TJP].
  1657. C-----------------------------------------------------------------------
  1658.       INCLUDE 'f77.GRPCKG1/IN'
  1659.       INTEGER I
  1660.       REAL    A0, A1, CR0, CG0, CB0, CR1, CG1, CB1
  1661.       INTRINSIC REAL
  1662. C-----------------------------------------------------------------------
  1663. C
  1664. C N.B. Arguments are assumed to be valid (checked by PGGRAY).
  1665. C
  1666. C Use GRIMG0 if this an appropriate device; first initialize the
  1667. C color table to a linear ramp between the colors assigned to color
  1668. C indices 0 and 1.
  1669. C
  1670.       IF (GRGCAP(GRCIDE)(7:7).NE.'N' .AND. MAXIND-MININD .GT. 15) THEN
  1671.          CALL GRQCR(0, CR0, CG0, CB0)
  1672.          CALL GRQCR(1, CR1, CG1, CB1)
  1673.          DO 5 I=MININD,MAXIND
  1674.             A0 = REAL(I-MININD)/REAL(MAXIND-MININD)
  1675.             A1 = 1.0 - A0
  1676.             CALL GRSCR(I, A0*CR0+A1*CR1, A0*CG0+A1*CG1, A0*CB0+A1*CB1)
  1677.  5       CONTINUE
  1678.          CALL GRIMG0(A, IDIM, JDIM, I1, I2, J1, J2,
  1679.      :               FG, BG, PA, MININD, MAXIND, MODE)
  1680.          RETURN
  1681. C
  1682. C Otherwise use random dither in current color index.
  1683. C
  1684.       ELSE
  1685.          CALL GRIMG3(A, IDIM, JDIM, I1, I2, J1, J2,
  1686.      :               FG, BG, PA, MODE)
  1687.       END IF
  1688. C-----------------------------------------------------------------------
  1689.       END
  1690.  
  1691. C*GRGTC0 -- obtain character digitization
  1692. C+
  1693.       SUBROUTINE GRGTC0 (CHAR,CENTER,POINTS,X,Y,MORE)
  1694. C
  1695. C GRPCKG (internal routine): obtain character digitization.
  1696. C
  1697. C (10-Feb-1983)
  1698. C-----------------------------------------------------------------------
  1699.       EXTERNAL GRDAT2
  1700.       LOGICAL CENTER
  1701.       INTEGER POINTS, CHAR
  1702.       REAL X(1)
  1703.       REAL Y(1)
  1704.       LOGICAL MORE
  1705. C
  1706.       INTEGER CINDX1, CINDX2
  1707.       INTEGER CTD1, CTD2
  1708.       PARAMETER (CTD1 = 30, CTD2 = 128)
  1709.       INTEGER CHTBL(CTD1, CTD2)
  1710.       COMMON /GRCS02/ CINDX1, CINDX2, CHTBL
  1711. C
  1712.       INTEGER I
  1713.       INTEGER COORDS
  1714.       LOGICAL TAILED
  1715. C-----------------------------------------------------------------------
  1716.       IF (CINDX2.LE.0) CINDX2 = CHAR + 1
  1717. C
  1718. C Get the next segment of the character.
  1719. C
  1720.       POINTS = CHTBL(CINDX1, CINDX2)
  1721.       IF(POINTS .EQ. 0) GO TO 240
  1722.       DO 220 I = 1, POINTS
  1723.           CINDX1 = CINDX1 + 1
  1724.           COORDS = CHTBL(CINDX1, CINDX2)
  1725.           TAILED = COORDS .LT. 0
  1726.           IF(TAILED) COORDS = IABS(COORDS)
  1727.           X(I) = FLOAT(COORDS / 10)
  1728.           Y(I) = FLOAT(MOD(COORDS, 10))
  1729.           IF(TAILED) Y(I) = - Y(I)
  1730.           IF(.NOT. CENTER) GO TO 220
  1731.           X(I) = X(I) - 3.0
  1732.           Y(I) = Y(I) - 4.0
  1733.   220     CONTINUE
  1734.   240 CONTINUE
  1735. C
  1736. C Set status and return.
  1737. C
  1738.       IF(CINDX1 .EQ. CTD1) GO TO 320
  1739.       CINDX1 = CINDX1 + 1
  1740.       IF(CHTBL(CINDX1, CINDX2) .EQ. 0) GO TO 320
  1741.       MORE = .TRUE.
  1742.       RETURN
  1743.   320 MORE = .FALSE.
  1744.       CINDX1 = 1
  1745.       CINDX2 = 0
  1746.       RETURN
  1747.       END
  1748. C*GRIMG0 -- color image of a 2D data array
  1749. C+
  1750.       SUBROUTINE GRIMG0 (A, IDIM, JDIM, I1, I2, J1, J2,
  1751.      1                   A1, A2, PA, MININD, MAXIND, MODE)
  1752.       INTEGER IDIM, JDIM, I1, I2, J1, J2, MININD, MAXIND, MODE
  1753.       REAL    A(IDIM,JDIM), A1, A2, PA(6)
  1754. C
  1755. C This is a support routine for PGIMAG.
  1756. C
  1757. C Arguments:
  1758. C  A      (input)  : the array to be plotted.
  1759. C  IDIM   (input)  : the first dimension of array A.
  1760. C  JDIM   (input)  : the second dimension of array A.
  1761. C  I1, I2 (input)  : the inclusive range of the first index
  1762. C                    (I) to be plotted.
  1763. C  J1, J2 (input)  : the inclusive range of the second
  1764. C                    index (J) to be plotted.
  1765. C  A1     (input)  : the array value which is to appear in color
  1766. C                    index MININD.
  1767. C  A2     (input)  : the array value which is to appear in color
  1768. C                    index MAXIND.
  1769. C  PA     (input)  : transformation matrix between array grid and
  1770. C                    device coordinates.
  1771. C  MININD (input)  : minimum color index to use.
  1772. C  MAXIND (input)  : maximum color index to use.
  1773. C  MODE   (input)  : =0 for linear, =1 for logarithmic, =2 for
  1774. C                    square-root mapping of array values to color
  1775. C                    indices.
  1776. C--
  1777. C  7-Sep-1994 - new routine [TJP].
  1778. C-----------------------------------------------------------------------
  1779.       INCLUDE 'f77.GRPCKG1/IN'
  1780.       CHARACTER C
  1781. C-----------------------------------------------------------------------
  1782. C
  1783. C Switch on type of device support.
  1784. C
  1785.       C = GRGCAP(GRCIDE)(7:7)
  1786.       IF (C.EQ.'Q') THEN
  1787. C         -- Image-primitive devices
  1788.           CALL GRIMG1(A, IDIM, JDIM, I1, I2, J1, J2, A1, A2, PA,
  1789.      :                MININD, MAXIND, MODE)
  1790.       ELSE IF (C.EQ.'P') THEN
  1791. C         -- Pixel-primitive devices         
  1792.           CALL GRIMG2(A, IDIM, JDIM, I1, I2, J1, J2, A1, A2, PA,
  1793.      :                MININD, MAXIND, MODE)
  1794.       ELSE IF (C.EQ.'N') THEN
  1795. C         -- Other devices
  1796.           CALL GRWARN(
  1797.      :     'images cannot be displayed on the selected device')
  1798.       ELSE
  1799. C         -- Unknown device code
  1800.           CALL GRWARN('unexpected error in routine GRIMG0')
  1801.       END IF
  1802. C-----------------------------------------------------------------------
  1803.       END
  1804. C*GRIMG1 -- image of a 2D data array (image-primitive devices)
  1805. C+
  1806.       SUBROUTINE GRIMG1 (A, IDIM, JDIM, I1, I2, J1, J2,
  1807.      1                   A1, A2, PA, MININD, MAXIND, MODE)
  1808.       INTEGER IDIM, JDIM, I1, I2, J1, J2, MININD, MAXIND, MODE
  1809.       REAL    A(IDIM,JDIM), A1, A2, PA(6)
  1810. C
  1811. C (This routine is called by GRIMG0.)
  1812. C--
  1813. C 7-Sep-1994  New routine [TJP].
  1814. C-----------------------------------------------------------------------
  1815.       INCLUDE 'f77.GRPCKG1/IN'
  1816.       INTEGER NBUF, LCHR
  1817.       REAL    RBUF(21), FAC, AV, SFAC, SFACL
  1818.       CHARACTER*1 CHR
  1819.       INTEGER  I, J, II, NXP, NYP, IV
  1820.       INTRINSIC NINT, LOG
  1821.       PARAMETER (SFAC=65000.0)
  1822. C-----------------------------------------------------------------------
  1823. C Size of image.
  1824. C
  1825.       NXP = I2 - I1 + 1
  1826.       NYP = J2 - J1 + 1
  1827.       RBUF(1) = 0.0
  1828.       RBUF(2) = NXP
  1829.       RBUF(3) = NYP
  1830. C
  1831. C Clipping rectangle.
  1832. C
  1833.       RBUF(4) = GRXMIN(GRCIDE)
  1834.       RBUF(5) = GRXMAX(GRCIDE)
  1835.       RBUF(6) = GRYMIN(GRCIDE)
  1836.       RBUF(7) = GRYMAX(GRCIDE)
  1837. C
  1838. C Image transformation matrix.
  1839. C
  1840.       FAC = PA(2)*PA(6) - PA(3)*PA(5)
  1841.       RBUF(8)  =  PA(6)/FAC
  1842.       RBUF(9)  = -PA(5)/FAC
  1843.       RBUF(10) = -PA(3)/FAC
  1844.       RBUF(11) =  PA(2)/FAC
  1845.       RBUF(12) = (PA(3)*PA(4) - PA(1)*PA(6))/FAC - (I1-0.5)
  1846.       RBUF(13) = (PA(5)*PA(1) - PA(4)*PA(2))/FAC - (J1-0.5)
  1847. C
  1848. C Send setup info to driver.
  1849. C
  1850.       IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  1851.       CALL GRTERM
  1852.       NBUF = 13
  1853.       LCHR = 0
  1854.       CALL GREXEC(GRGTYP, 26, RBUF, NBUF, CHR, LCHR)
  1855. C
  1856. C Convert image array to color indices and send to driver.
  1857. C
  1858.       SFACL = LOG(1.0+SFAC)
  1859.       II = 0
  1860.       DO 20 J = J1,J2
  1861.           DO 10 I = I1,I2
  1862.               AV = A(I,J)
  1863.               IF (A2.GT.A1) THEN
  1864.                   AV = MIN(A2, MAX(A1,AV))
  1865.               ELSE
  1866.                   AV = MIN(A1, MAX(A2,AV))
  1867.               END IF
  1868.               IF (MODE.EQ.0) THEN
  1869.                 IV = NINT((MININD*(A2-AV) + MAXIND*(AV-A1))/(A2-A1))
  1870.               ELSE IF (MODE.EQ.1) THEN
  1871.                 IV = MININD + NINT((MAXIND-MININD)*
  1872.      :               LOG(1.0+SFAC*ABS((AV-A1)/(A2-A1)))/SFACL)
  1873.               ELSE IF (MODE.EQ.2) THEN
  1874.                 IV = MININD + NINT((MAXIND-MININD)*
  1875.      :                             SQRT(ABS((AV-A1)/(A2-A1))))
  1876.               ELSE
  1877.                 IV = MININD
  1878.               END IF
  1879.               II = II + 1
  1880.               RBUF(II+1) = IV
  1881.               IF (II.EQ.20) THEN
  1882.                   NBUF = II + 1
  1883.                   RBUF(1) = II
  1884.                   CALL GREXEC(GRGTYP, 26, RBUF, NBUF, CHR, LCHR)
  1885.                   II = 0
  1886.               END IF
  1887.    10     CONTINUE
  1888.    20 CONTINUE
  1889.       IF (II.GT.0) THEN
  1890.           NBUF = II + 1
  1891.           RBUF(1) = II
  1892.           CALL GREXEC(GRGTYP, 26, RBUF, NBUF, CHR, LCHR)
  1893.           II = 0
  1894.       END IF
  1895. C
  1896. C Send termination code to driver.
  1897. C
  1898.       NBUF = 1
  1899.       RBUF(1) = -1
  1900.       CALL GREXEC(GRGTYP, 26, RBUF, NBUF, CHR, LCHR)
  1901. C-----------------------------------------------------------------------
  1902.       END
  1903. C*GRIMG2 -- image of a 2D data array (pixel-primitive devices)
  1904. C+
  1905.       SUBROUTINE GRIMG2 (A, IDIM, JDIM, I1, I2, J1, J2,
  1906.      1                   A1, A2, PA, MININD, MAXIND, MODE)
  1907.       INTEGER IDIM, JDIM, I1, I2, J1, J2, MININD, MAXIND, MODE
  1908.       REAL    A(IDIM,JDIM)
  1909.       REAL    A1, A2
  1910.       REAL    PA(6)
  1911. C
  1912. C (This routine is called by GRIMG0.)
  1913. C--
  1914. C 7-Sep-1994  New routine [TJP].
  1915. C-----------------------------------------------------------------------
  1916.       INCLUDE 'f77.GRPCKG1/IN'
  1917.       INTEGER  I,IV,IX,IX1,IX2,IY,IY1,IY2,J, NPIX, LCHR
  1918.       REAL     DEN, AV, SFAC, SFACL
  1919.       REAL     XXAA,XXBB,YYAA,YYBB,XYAA,XYBB,YXAA,YXBB,XYAAIY,YXAAIY
  1920.       REAL     BUFFER(1026)
  1921.       CHARACTER*1 CHR
  1922.       INTRINSIC NINT, LOG
  1923.       PARAMETER (SFAC=65000.0)
  1924. C-----------------------------------------------------------------------
  1925. C
  1926. C Location of current window in device coordinates.
  1927. C
  1928.       IX1 = NINT(GRXMIN(GRCIDE))+1
  1929.       IX2 = NINT(GRXMAX(GRCIDE))-1
  1930.       IY1 = NINT(GRYMIN(GRCIDE))+1
  1931.       IY2 = NINT(GRYMAX(GRCIDE))-1
  1932. C
  1933. C Transformation from array coordinates to device coordinates.
  1934. C
  1935.       DEN = PA(2)*PA(6)-PA(3)*PA(5)
  1936.       XXAA = -PA(6)*PA(1)/DEN
  1937.       XXBB = PA(6)/DEN
  1938.       XYAA = -PA(3)*PA(4)/DEN
  1939.       XYBB = PA(3)/DEN
  1940.       YYAA = -PA(2)*PA(4)/DEN
  1941.       YYBB = PA(2)/DEN
  1942.       YXAA = -PA(5)*PA(1)/DEN
  1943.       YXBB = PA(5)/DEN
  1944. C
  1945. C Start a new page if necessary.
  1946. C
  1947.       IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  1948. C
  1949. C Run through every device pixel (IX, IY) in the current window and
  1950. C determine which array pixel (I,J) it falls in.
  1951. C
  1952.       SFACL = LOG(1.0+SFAC)
  1953.       DO 120 IY=IY1,IY2
  1954.           XYAAIY = XXAA-XYAA-XYBB*IY
  1955.           YXAAIY = YYAA+YYBB*IY-YXAA
  1956.           NPIX = 0
  1957.           BUFFER(2) = IY
  1958.           DO 110 IX=IX1,IX2
  1959.             I = NINT(XYAAIY+XXBB*IX)
  1960.             IF (I.LT.I1.OR.I.GT.I2) GOTO 110
  1961.             J = NINT(YXAAIY-YXBB*IX)
  1962.             IF (J.LT.J1.OR.J.GT.J2) GOTO 110
  1963. C
  1964. C           -- determine color index IV of this pixel
  1965. C
  1966.             AV = A(I,J)
  1967.             IF (A2.GT.A1) THEN
  1968.                 AV = MIN(A2, MAX(A1,AV))
  1969.             ELSE
  1970.                 AV = MIN(A1, MAX(A2,AV))
  1971.             END IF
  1972.             IF (MODE.EQ.0) THEN
  1973.                 IV = NINT((MININD*(A2-AV) + MAXIND*(AV-A1))/(A2-A1))
  1974.             ELSE IF (MODE.EQ.1) THEN
  1975.                 IV = MININD + NINT((MAXIND-MININD)*
  1976.      :               LOG(1.0+SFAC*ABS((AV-A1)/(A2-A1)))/SFACL)
  1977.             ELSE IF (MODE.EQ.2) THEN
  1978.                 IV = MININD + NINT((MAXIND-MININD)*
  1979.      :                             SQRT(ABS((AV-A1)/(A2-A1))))
  1980.             ELSE
  1981.                 IV = MININD
  1982.             END IF
  1983. C
  1984.             IF (NPIX.LE.1024) THEN
  1985. C               -- drop pixels if buffer too small (to be fixed!)
  1986.                 NPIX = NPIX+1
  1987.                 IF (NPIX.EQ.1) BUFFER(1) = IX
  1988.                 BUFFER(NPIX+2) = IV
  1989.             END IF
  1990.   110     CONTINUE
  1991.           IF (NPIX.GT.0) CALL 
  1992.      :                   GREXEC(GRGTYP, 26, BUFFER, NPIX+2, CHR, LCHR)
  1993.   120 CONTINUE
  1994. C-----------------------------------------------------------------------
  1995.       END
  1996. C*GRIMG3 -- gray-scale map of a 2D data array, using dither
  1997. C+
  1998.       SUBROUTINE GRIMG3 (A, IDIM, JDIM, I1, I2, J1, J2,
  1999.      1                   BLACK, WHITE, PA, MODE)
  2000.       INTEGER IDIM, JDIM, I1, I2, J1, J2, MODE
  2001.       REAL    A(IDIM,JDIM)
  2002.       REAL    BLACK, WHITE
  2003.       REAL    PA(6)
  2004. C--
  2005. C 2-Sep-1994 - moved from GRGRAY [TJP].
  2006. C-----------------------------------------------------------------------
  2007.       INCLUDE 'f77.GRPCKG1/IN'
  2008.       INTEGER  I,IX,IX1,IX2,IY,IY1,IY2,J
  2009.       REAL     DEN,VALUE,BW
  2010.       REAL     XXAA,XXBB,YYAA,YYBB,XYAA,XYBB,YXAA,YXBB,XYAAIY,YXAAIY
  2011.       INTEGER  M, IAA, ICC, JRAN, ILAST, JLAST, IXSTEP, IYSTEP
  2012.       REAL     RAND, RM, FAC, FACL
  2013.       PARAMETER (M=714025, IAA=1366, ICC=150889, RM=1.0/M)
  2014.       PARAMETER (FAC=65000.0)
  2015.       INTRINSIC MOD, NINT, REAL, LOG
  2016. C-----------------------------------------------------------------------
  2017. C
  2018.       IF (MODE.LT.0 .OR. MODE.GT.2) RETURN
  2019. C
  2020. C Initialize random-number generator (based on RAN2 of Press et al.,
  2021. C Numerical Recipes)
  2022. C
  2023.       JRAN = 76773
  2024. C
  2025.       IX1 = NINT(GRXMIN(GRCIDE))+1
  2026.       IX2 = NINT(GRXMAX(GRCIDE))-1
  2027.       IY1 = NINT(GRYMIN(GRCIDE))+1
  2028.       IY2 = NINT(GRYMAX(GRCIDE))-1
  2029.       DEN = PA(2)*PA(6)-PA(3)*PA(5)
  2030. C
  2031. C Calculate constants.
  2032. C
  2033.       BW   = ABS(BLACK-WHITE)
  2034.       FACL = LOG(1.0+FAC)
  2035.       XXAA = -PA(6)*PA(1)/DEN
  2036.       XXBB = PA(6)/DEN
  2037.       XYAA = -PA(3)*PA(4)/DEN
  2038.       XYBB = PA(3)/DEN
  2039.       YYAA = -PA(2)*PA(4)/DEN
  2040.       YYBB = PA(2)/DEN
  2041.       YXAA = -PA(5)*PA(1)/DEN
  2042.       YXBB = PA(5)/DEN
  2043. C
  2044. C Choose step size: at least 1/200 inch, assuming the line-width
  2045. C unit is 1/200 inch.
  2046. C
  2047.       IXSTEP = MAX(1,NINT(GRWIDT(GRCIDE)*GRPXPI(GRCIDE)/200.0))
  2048.       IYSTEP = MAX(1,NINT(GRWIDT(GRCIDE)*GRPYPI(GRCIDE)/200.0))
  2049. C
  2050. C Draw dots.
  2051. C
  2052.       ILAST = 0
  2053.       JLAST = 0
  2054.       DO 120 IY=IY1,IY2,IYSTEP
  2055.           XYAAIY = XXAA-XYAA-XYBB*IY
  2056.           YXAAIY = YYAA+YYBB*IY-YXAA
  2057.           DO 110 IX=IX1,IX2,IXSTEP
  2058.               I = NINT(XYAAIY+XXBB*IX)
  2059.               IF (I.LT.I1.OR.I.GT.I2) GOTO 110
  2060.               J = NINT(YXAAIY-YXBB*IX)
  2061.               IF (J.LT.J1.OR.J.GT.J2) GOTO 110
  2062.               IF (I.NE.ILAST .OR. J.NE.JLAST) THEN
  2063.                   ILAST = I
  2064.                   JLAST = J
  2065.                   VALUE = ABS(A(I,J)-WHITE)/BW
  2066.                   IF (MODE.EQ.0) THEN
  2067. C                     -- "linear"
  2068.                       CONTINUE
  2069.                   ELSE IF (MODE.EQ.1) THEN
  2070. C                     -- "logarithmic"
  2071.                       VALUE = LOG(1.0+FAC*VALUE)/FACL
  2072.                   ELSE IF (MODE.EQ.2) THEN
  2073. C                     -- "square root"
  2074.                       VALUE = SQRT(VALUE)
  2075.                   END IF
  2076.               END IF
  2077.               JRAN = MOD(JRAN*IAA+ICC, M)
  2078.               RAND = JRAN*RM
  2079.               IF (VALUE.GT.RAND) CALL GRDOT0(REAL(IX),REAL(IY))
  2080.   110     CONTINUE
  2081.   120  CONTINUE
  2082. C-----------------------------------------------------------------------
  2083.        END
  2084. C*GRINIT -- initialize GRPCKG
  2085. C+
  2086.       SUBROUTINE GRINIT
  2087. C
  2088. C Initialize GRPCKG and read font file. Called by GROPEN, but may be 
  2089. C called explicitly if needed.
  2090. C--
  2091. C 29-Apr-1996 - new routine [TJP].
  2092. C-----------------------------------------------------------------------
  2093.       INCLUDE 'f77.GRPCKG1/IN'
  2094.       INTEGER   I
  2095.       LOGICAL   INIT
  2096.       SAVE      INIT
  2097.       DATA      INIT / .TRUE. /
  2098. C
  2099.       IF (INIT) THEN
  2100.          DO 10 I=1,GRIMAX
  2101.             GRSTAT(I) = 0
  2102.  10      CONTINUE
  2103.          CALL GRSY00
  2104.          INIT = .FALSE.
  2105.       END IF
  2106.       RETURN
  2107.       END
  2108. C*GRINQFONT -- inquire current font [obsolete]
  2109. C
  2110.       SUBROUTINE GRINQFONT (IF)
  2111.       INTEGER IF
  2112.       CALL GRQFNT(IF)
  2113.       END
  2114.  
  2115. C*GRINQLI -- *obsolete routine*
  2116. C+
  2117.       SUBROUTINE GRINQLI (INTEN)
  2118. C
  2119. C GRPCKG: obtain the line intensity of the current graphics device.
  2120. C Obsolete routine.
  2121. C Argument:
  2122. C
  2123. C INTEN (integer, output): always returns 1.
  2124. C--
  2125. C (1-Feb-1983; revised 16-Aug-1987).
  2126. C-----------------------------------------------------------------------
  2127.       INTEGER  INTEN
  2128. C
  2129.       INTEN = 1
  2130.       END
  2131.  
  2132. C*GRINQPEN -- *obsolete routine*
  2133. C+
  2134.       SUBROUTINE GRINQPEN (IP)
  2135. C
  2136. C GRPCKG: obtain the pen number of the current graphics device.
  2137. C Obsolete routine.
  2138. C Argument:
  2139. C
  2140. C IP (integer, output): always receives 1.
  2141. C--
  2142. C 16-Aug-1987 - [TJP].
  2143. C-----------------------------------------------------------------------
  2144.       INTEGER  IP
  2145. C
  2146.       IP = 1
  2147.       END
  2148. C*GRITOC - convert integer to character string
  2149. C+
  2150.       INTEGER FUNCTION GRITOC(INT, STR)
  2151.       INTEGER INT
  2152.       CHARACTER*(*) STR
  2153. C
  2154. C Convert integer INT into (decimal) character string in STR.
  2155. C-----------------------------------------------------------------------
  2156.       CHARACTER*10 DIGITS
  2157.       INTEGER D, I, INTVAL, J, L
  2158.       CHARACTER K
  2159.       DATA DIGITS /'0123456789'/
  2160. C
  2161.       INTVAL = ABS(INT)
  2162.       I = 0
  2163. C
  2164. C Generate digits in reverse order.
  2165. C
  2166.   10  CONTINUE
  2167.           I = I+1
  2168.           D = 1 + MOD(INTVAL, 10)
  2169.           STR(I:I) = DIGITS(D:D)
  2170.           INTVAL = INTVAL/10
  2171.           IF (I.LT.LEN(STR) .AND. INTVAL.NE.0) GOTO 10
  2172. C
  2173. C Add minus sign if necessary.
  2174. C
  2175.       IF (INT.LT.0 .AND. I.LT.LEN(STR)) THEN
  2176.           I = I+1
  2177.           STR(I:I) = '-'
  2178.       END IF
  2179.       GRITOC = I
  2180. C
  2181. C Reverse string in place.
  2182. C
  2183.       L = I/2
  2184.       DO 20 J=1,L
  2185.           K = STR(I:I)
  2186.           STR(I:I) = STR(J:J)
  2187.           STR(J:J) = K
  2188.           I = I-1
  2189.    20 CONTINUE
  2190. C-----------------------------------------------------------------------
  2191.       END
  2192. C*GRLDEV -- list supported device types
  2193. C+
  2194.       SUBROUTINE GRLDEV
  2195. C
  2196. C Support routine for PGLDEV.
  2197. C
  2198. C Arguments: none
  2199. C--
  2200. C  5-Aug-1986 [AFT]
  2201. C 13-Dec-1990 Change warnings to messages [TJP].
  2202. C 18-Jan-1993 Display one per line [TJP].
  2203. C 13-Jan-1995 Change message [TJP].
  2204. C 10-Nov-1995 Ignore device types of zero length [TJP].
  2205. C-----------------------------------------------------------------------
  2206.       INCLUDE 'f77.GRPCKG1/IN'
  2207.       INTEGER I,NDEV,NBUF,LCHR
  2208.       REAL    RBUF(6)
  2209.       CHARACTER*72 CHR
  2210.       CHARACTER*72 TEXT
  2211. C---
  2212.       CALL GRMSG('Device types available:')
  2213. C--- First obtain number of devices.
  2214.       CALL GREXEC(0,0,RBUF,NBUF,CHR,LCHR)
  2215.       NDEV=NINT(RBUF(1))
  2216. C
  2217.       DO 10 I=1,NDEV
  2218.          CALL GREXEC(I, 1,RBUF,NBUF,CHR,LCHR)
  2219.          IF (LCHR.GT.0) THEN
  2220.             TEXT(1:1) = '/'
  2221.             TEXT(2:) = CHR(:LCHR)
  2222.             CALL GRMSG(TEXT)
  2223.          END IF
  2224.  10   CONTINUE
  2225. C
  2226.       END
  2227. C*GRLEN -- inquire plotted length of character string
  2228. C+
  2229.       SUBROUTINE GRLEN (STRING, D)
  2230. C
  2231. C GRPCKG: length of text string (absolute units)
  2232. C--
  2233. C (3-Mar-1983)
  2234. C 19-Jan-1988 - remove unused label [TJP].
  2235. C  9-Sep-1989 - standardize [TJP].
  2236. C-----------------------------------------------------------------------
  2237.       INCLUDE 'f77.GRPCKG1/IN'
  2238.       LOGICAL UNUSED
  2239.       INTEGER XYGRID(300)
  2240.       INTEGER LIST(256)
  2241.       CHARACTER*(*) STRING
  2242.       REAL FACTOR, COSA, SINA, DX, D, RATIO, FNTBAS, FNTFAC
  2243.       INTEGER I, IFNTLV, LX, NLIST
  2244.       INTRINSIC ABS, LEN
  2245. C
  2246.       D = 0.0
  2247.       IF (LEN(STRING).LE.0) RETURN
  2248. C-----------------------------------------------------------------------
  2249. C               Compute scaling and orientation
  2250. C-----------------------------------------------------------------------
  2251.       FACTOR = GRCFAC(GRCIDE)/2.5
  2252.       RATIO = GRPXPI(GRCIDE)/GRPYPI(GRCIDE)
  2253.       COSA = FACTOR
  2254.       SINA = 0.0
  2255.       FNTBAS = 0.0
  2256.       FNTFAC = 1.0
  2257.       IFNTLV = 0
  2258. C
  2259. C               Convert string to symbol numbers:
  2260. C               \u and \d escape sequences are converted to -1,-2
  2261. C
  2262.       CALL GRSYDS(LIST,NLIST,STRING,GRCFNT(GRCIDE))
  2263. C
  2264. C               Plot the string of characters
  2265. C
  2266.       DO 380 I = 1,NLIST
  2267.           IF (LIST(I).LT.0) THEN
  2268.               IF (LIST(I).EQ.-1) THEN
  2269.                   IFNTLV = IFNTLV+1
  2270.                   FNTBAS = FNTBAS + 16.0*FNTFAC
  2271.                   FNTFAC = 0.6**ABS(IFNTLV)
  2272.               ELSE IF (LIST(I).EQ.-2) THEN
  2273.                   IFNTLV = IFNTLV-1
  2274.                   FNTFAC = 0.6**ABS(IFNTLV)
  2275.                   FNTBAS = FNTBAS - 16.0*FNTFAC
  2276.               END IF
  2277.               GOTO 380
  2278.           END IF
  2279.           CALL GRSYXD(LIST(I),XYGRID,UNUSED)
  2280.           LX = XYGRID(5)-XYGRID(4)
  2281.           DX = COSA*LX*RATIO
  2282.           D = D + DX*FNTFAC
  2283.   380 CONTINUE
  2284. C
  2285.       END
  2286. C*GRLIN0 -- draw a line
  2287. C+
  2288.       SUBROUTINE GRLIN0 (XP,YP)
  2289. C
  2290. C GRPCKG (internal routine): draw a line from the current position to a
  2291. C specified position, which becomes the new current position. This
  2292. C routine takes care of clipping at the viewport boundary, dashed and
  2293. C thick lines.
  2294. C
  2295. C Arguments:
  2296. C
  2297. C XP, YP (input, real): absolute device coordinates of the end-point of
  2298. C       the line.
  2299. C--
  2300. C 13-Jul-1984
  2301. C  7-May-1985 - add MIN/MAX kluge to prevent integer overflow [TJP].
  2302. C-----------------------------------------------------------------------
  2303.       INCLUDE 'f77.GRPCKG1/IN'
  2304.       LOGICAL  VIS
  2305.       REAL     XP,YP, X0,Y0, X1,Y1
  2306. C
  2307. C End-points of line are (X0,Y0), (X1,Y1).
  2308. C
  2309.       X0 = GRXPRE(GRCIDE)
  2310.       Y0 = GRYPRE(GRCIDE)
  2311.       X1 = MIN(2E9,MAX(-2E9,XP))
  2312.       Y1 = MIN(2E9,MAX(-2E9,YP))
  2313.       GRXPRE(GRCIDE) = X1
  2314.       GRYPRE(GRCIDE) = Y1
  2315. C
  2316. C Change the end-points of the line (X0,Y0) - (X1,Y1)
  2317. C to clip the line at the window boundary.
  2318. C
  2319.       CALL GRCLPL(X0,Y0,X1,Y1,VIS)
  2320.       IF (.NOT.VIS) RETURN
  2321. C
  2322. C Draw the line in the appropriate style.
  2323. C
  2324.       IF (GRDASH(GRCIDE)) THEN
  2325. C         ! dashed line
  2326.          CALL GRLIN1(X0,Y0,X1,Y1,.FALSE.)
  2327.       ELSE IF (GRWIDT(GRCIDE).GT.1) THEN
  2328. C         ! heavy line
  2329.          CALL GRLIN3(X0,Y0,X1,Y1)
  2330.       ELSE
  2331. C         ! full line
  2332.          CALL GRLIN2(X0,Y0,X1,Y1)
  2333.       END IF
  2334.       END
  2335. C*GRLIN1 -- draw a dashed line
  2336. C+
  2337.       SUBROUTINE GRLIN1 (X0,Y0,X1,Y1,RESET)
  2338. C
  2339. C GRPCKG : dashed line. Generate a visible dashed line between points
  2340. C (X0,Y0) and (X1,Y1) according to the dash pattern stored in common.
  2341. C If RESET = .TRUE., the pattern will start from the beginning.
  2342. C Otherwise, it will continue from its last position.
  2343. C     DASHED LINE PATTERN ARRAY CONTAINING LENGTHS OF
  2344. C          MARKS AND SPACES IN UNIT CUBE: GRPATN(*)
  2345. C     OFFSET IN CURRENT PATTERN SEGMENT: GRPOFF
  2346. C     CURRENT PATTERN SEGMENT NUMBER: GRIPAT
  2347. C     NUMBER OF PATTERN SEGMENTS: 8
  2348. C--
  2349. C (1-Feb-1983)
  2350. C  6-Sep-1989 - Changes for standard Fortran-77 [TJP].
  2351. C-----------------------------------------------------------------------
  2352.       INCLUDE 'f77.GRPCKG1/IN'
  2353. C
  2354.       REAL ADJUST, ARG1, ARG2, ALFARG
  2355.       REAL SCALE, SEGLEN, X1, X0, Y1, Y0, DS, DSOLD
  2356.       REAL ALPHA1, ALPHA2, XP, YP, XQ, YQ
  2357.       LOGICAL RESET
  2358.       INTEGER THICK
  2359.       INTRINSIC ABS, MIN, MOD, REAL, SQRT
  2360. C
  2361.       ADJUST(ARG1,ARG2,ALFARG) = ALFARG*(ARG2 - ARG1) + ARG1
  2362. C
  2363.       THICK = GRWIDT(GRCIDE)
  2364.       SCALE = SQRT(REAL(ABS(THICK)))
  2365.       IF (RESET) THEN
  2366.           GRPOFF(GRCIDE) = 0.0
  2367.           GRIPAT(GRCIDE) = 1
  2368.       END IF
  2369.       SEGLEN = SQRT((X1-X0)**2 + (Y1-Y0)**2)
  2370.       IF (SEGLEN .EQ. 0.0) RETURN
  2371.       DS = 0.0
  2372. C
  2373. C       Repeat until (ALPHA2 .GE. 1.0)
  2374. C
  2375. C       Line segments matching the pattern segments are determined
  2376. C       by finding values (ALPHA1,ALPHA2) defining the start and end
  2377. C       of the segment in the parametric equation (1-ALPHA)*P1 + ALPHA*P2
  2378. C       defining the line.  DS measures the progress along the line
  2379. C       segment and defines the starting ALPHA1.  The ending ALPHA2
  2380. C       is computed from the end of the current pattern mark or space
  2381. C       or the segment end, whichever comes first.
  2382. C
  2383.    10 DSOLD = DS
  2384.       ALPHA1 = DS/SEGLEN
  2385.       ALPHA2 = MIN(1.0,(DS+SCALE*GRPATN(GRCIDE,GRIPAT(GRCIDE))-
  2386.      1           GRPOFF(GRCIDE))/SEGLEN)
  2387.       IF (MOD(GRIPAT(GRCIDE),2) .NE. 0) THEN
  2388.           XP = ADJUST(X0,X1,ALPHA1)
  2389.           YP = ADJUST(Y0,Y1,ALPHA1)
  2390.           XQ = ADJUST(X0,X1,ALPHA2)
  2391.           YQ = ADJUST(Y0,Y1,ALPHA2)
  2392.           IF (THICK.GT.1) THEN
  2393.               CALL GRLIN3(XP,YP,XQ,YQ)
  2394.           ELSE
  2395.               CALL GRLIN2(XP,YP,XQ,YQ)
  2396.           END IF
  2397.       END IF
  2398.       DS = ALPHA2*SEGLEN
  2399.       IF (ALPHA2 .GE. 1.0) THEN
  2400.           GRPOFF(GRCIDE) = GRPOFF(GRCIDE) + DS - DSOLD
  2401.           RETURN
  2402.       END IF
  2403.       GRIPAT(GRCIDE) = MOD(GRIPAT(GRCIDE),8) + 1
  2404.       GRPOFF(GRCIDE) = 0.0
  2405.       GO TO 10
  2406.       END
  2407.  
  2408. C*GRLIN2 -- draw a normal line
  2409. C+
  2410.       SUBROUTINE GRLIN2 (X0,Y0,X1,Y1)
  2411. C
  2412. C GRPCKG : plot a visible line segment in absolute coords from
  2413. C (X0,Y0) to (X1,Y1).  The endpoints of the line segment are rounded
  2414. C to the nearest integer and passed to the appropriate device-specific
  2415. C routine. It is assumed that the entire line-segment lies within the
  2416. C view surface, and that the physical device coordinates are
  2417. C non-negative.
  2418. C--
  2419. C (1-Jun-1984)
  2420. C 19-Oct-1984 - rewritten for speed [TJP].
  2421. C 29-Jan-1985 - add HP2648 device [KS/TJP].
  2422. C  5-Aug-1986 - add GREXEC support [AFT].
  2423. C 21-Feb-1987 - If needed, calls begin picture [AFT].
  2424. C-----------------------------------------------------------------------
  2425.       INCLUDE 'f77.GRPCKG1/IN'
  2426.       REAL    X0,Y0,X1,Y1
  2427.       REAL    RBUF(6)
  2428.       INTEGER NBUF,LCHR
  2429.       CHARACTER CHR
  2430. C
  2431. C- If this is first thing plotted then set something plotted flag
  2432. C- and for a GREXEC device call BEGIN_PICTURE.
  2433. C
  2434.       IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  2435. C---
  2436.       RBUF(1)=X0
  2437.       RBUF(2)=Y0
  2438.       RBUF(3)=X1
  2439.       RBUF(4)=Y1
  2440.       NBUF=4
  2441.       CALL GREXEC(GRGTYP,12,RBUF,NBUF,CHR,LCHR)
  2442. C
  2443.       END
  2444. C*GRLIN3 -- draw a thick line (multiple strokes)
  2445. C+
  2446.       SUBROUTINE GRLIN3 (X0,Y0,X1,Y1)
  2447. C
  2448. C GRPCKG: draw a heavy line from (X0,Y0) to (X1,Y1) by making multiple
  2449. C strokes.  In order to simulate a thick pen, the line drawn has
  2450. C circular, rather than square, end points.  If this is not done,
  2451. C thick letters and other figures have an abnormal and unpleasant
  2452. C appearance.
  2453. C
  2454. C Vocabulary:
  2455. C
  2456. C LINEWT: the number of strokes required to draw the line; if
  2457. C       this is odd, one stroke will lie along the requested vector.
  2458. C       The nominal line thickness is (LINEWT-1)*0.005 in.
  2459. C RSQURD: the square of the semi-line thickness.
  2460. C (DX,DY): the vector length of the line.
  2461. C (VX,VY): a vector of length 1 pixel in the direction of the line.
  2462. C (VY,-VX): a vector of length 1 pixel perpendicular to (VX,VY).
  2463. C OFF: the offset parallel to (VY,-VX) of the K'th stroke.
  2464. C (VXK,VYK): the vector increment of the K'th stroke to allow for the
  2465. C       semi-circular terminal on the line.
  2466. C (PXK,PYK): the vector offset of the K'th stroke perpendicular to the
  2467. C       line vector.
  2468. C--
  2469. C (1-Feb-1983)
  2470. C 23-Nov-1994 - change algorithm so that the unit of line-width is
  2471. C               0.005 inch instead of 1 pixel [TJP].
  2472. C March 1995 - added ABS to prevent domain error in SQRT (CTD)
  2473. C-----------------------------------------------------------------------
  2474.       INCLUDE 'f77.GRPCKG1/IN'
  2475.       INTEGER  K,LINEWT
  2476.       REAL     DX,DY, HK, OFF, PXK,PYK, RSQURD, VLEN,VX,VY,VXK,VYK
  2477.       REAL     X0,X1,Y0,Y1
  2478.       REAL     XS0,XS1, YS0,YS1, SPIX,SPIY
  2479.       LOGICAL  VIS
  2480. C
  2481. C Determine number of strokes and line thickness.
  2482. C
  2483.       LINEWT = GRWIDT(GRCIDE)
  2484.       RSQURD = ((LINEWT-1)**2)*0.25
  2485. C
  2486. C Determine the vectors (VX,VY), (VY,-VX). If the line-length is zero,
  2487. C pretend it is a very short horizontal line.
  2488. C
  2489.       DX = X1 - X0
  2490.       DY = Y1 - Y0
  2491.       VLEN = SQRT(DX**2 + DY**2)
  2492.       SPIX = GRPXPI(GRCIDE)*0.005
  2493.       SPIY = GRPYPI(GRCIDE)*0.005
  2494. C
  2495.       IF (VLEN .EQ. 0.0) THEN
  2496.           VX = SPIX
  2497.           VY = 0.0
  2498.       ELSE
  2499.           VX = DX/VLEN*SPIX
  2500.           VY = DY/VLEN*SPIY
  2501.       END IF
  2502. C
  2503. C Draw LINEWT strokes. We have to clip again in case thickening the
  2504. C line has taken us outside the window.
  2505. C
  2506.       OFF = (LINEWT-1)*0.5
  2507.       DO 10 K=1,LINEWT
  2508.           PXK = VY*OFF
  2509.           PYK = -VX*OFF
  2510.           HK  = SQRT(ABS(RSQURD - OFF**2))
  2511.           VXK = VX*HK
  2512.           VYK = VY*HK
  2513.           XS1 = X1+PXK+VXK
  2514.           YS1 = Y1+PYK+VYK
  2515.           XS0 = X0+PXK-VXK
  2516.           YS0 = Y0+PYK-VYK
  2517.           CALL GRCLPL(XS1,YS1,XS0,YS0,VIS)
  2518.           IF (VIS) CALL GRLIN2(XS1, YS1, XS0, YS0)
  2519.           OFF = OFF - 1.0
  2520.    10 CONTINUE
  2521.       END
  2522.  
  2523. C*GRLINA -- draw a line (absolute, world coordinates)
  2524. C+
  2525.       SUBROUTINE GRLINA (X,Y)
  2526. C
  2527. C GRPCKG: draw line from current position to a specified position.
  2528. C
  2529. C Arguments:
  2530. C
  2531. C X, Y (real, input): world coordinates of the end-point of the line.
  2532. C--
  2533. C (1-Feb-1983)
  2534. C-----------------------------------------------------------------------
  2535.       INCLUDE 'f77.GRPCKG1/IN'
  2536.       REAL     X,Y
  2537. C
  2538.       IF (GRCIDE.GE.1) THEN
  2539.           CALL GRLIN0( X * GRXSCL(GRCIDE) + GRXORG(GRCIDE),
  2540.      1                 Y * GRYSCL(GRCIDE) + GRYORG(GRCIDE) )
  2541.       END IF
  2542.       END
  2543.  
  2544. C*GRLINR -- draw a line (relative, world coordinates)
  2545. C+
  2546.       SUBROUTINE GRLINR (DX,DY)
  2547. C
  2548. C GRPCKG: draw a line from the current position by a specified
  2549. C relative displacement.
  2550. C
  2551. C Arguments:
  2552. C
  2553. C DX, DY (real, input): the displacement in world coordinates: the pen
  2554. C       position is incremented by DX in x and DY in y.
  2555. C--
  2556. C (1-Feb-1983)
  2557. C-----------------------------------------------------------------------
  2558.       INCLUDE 'f77.GRPCKG1/IN'
  2559.       REAL     DX,DY
  2560. C
  2561.       IF (GRCIDE.GE.1) THEN
  2562.           CALL GRLIN0( DX * GRXSCL(GRCIDE) + GRXPRE(GRCIDE),
  2563.      1                 DY * GRYSCL(GRCIDE) + GRYPRE(GRCIDE) )
  2564.       END IF
  2565.       END
  2566.  
  2567. C*GRMARK -- mark points with specified symbol
  2568. C+
  2569.       SUBROUTINE GRMARK (IDENT,CENTER,SYMBOL,ABSXY,POINTS,X,Y)
  2570. C
  2571. C GRPCKG: mark a sequence of points with a specified symbol. The
  2572. C plot is windowed in the current subarea.
  2573. C
  2574. C Arguments:
  2575. C
  2576. C IDENT (integer, input): plot identifier from GROPEN.
  2577. C CENTER (input, logical): if .TRUE. the symbol is centered on the point,
  2578. C      otherwise the bottom left corner is placed at the point.
  2579. C SYMBOL (byte or integer, input): code number of symbol in range 0-127
  2580. C      (ASCII character or special symbol); if SYMBOL is outside this
  2581. C      range, nothing is plotted.
  2582. C ABSXY (logical, input): if .TRUE. (X,Y) are absolute (device)
  2583. C      coordinates; otherwise they are world coordinates and the
  2584. C      scaling transformation is applied.
  2585. C POINTS (integer, input): the number of points; if POINTS is less than
  2586. C      or equal to 0, nothing is plotted.
  2587. C X,Y (real arrays, dimension at least POINTS, input): the coordinate
  2588. C      pairs; if POINTS=1, these may be scalars instead of arrays.
  2589. C
  2590. C (9-Mar-1983)
  2591. C-----------------------------------------------------------------------
  2592.       INTEGER  SYMBOL
  2593.       CHARACTER*1 MARK
  2594.       INTEGER  I, IDENT, POINTS
  2595.       LOGICAL  ABSXY, CENTER
  2596.       REAL     X(*), Y(*)
  2597. C-----------------------------------------------------------------------
  2598.       IF (POINTS.LE.0 .OR. SYMBOL.LT.0 .OR. SYMBOL.GT.127) RETURN
  2599.       CALL GRSLCT(IDENT)
  2600.       MARK = CHAR(SYMBOL)
  2601.       DO 10 I=1,POINTS
  2602.           CALL GRCHR0(.TRUE., CENTER, 0.0, ABSXY, X(I), Y(I), MARK)
  2603.    10 CONTINUE
  2604. C-----------------------------------------------------------------------
  2605.       END
  2606.       SUBROUTINE GRMCUR (ICH, ICX, ICY)
  2607.       INTEGER ICH, ICX, ICY
  2608. C
  2609. C Cursor movement:
  2610. C Input: ICH character code
  2611. C In/Out: ICX, ICY cursor position
  2612. C-----------------------------------------------------------------------
  2613.       INTEGER STEP
  2614.       SAVE STEP
  2615.       DATA STEP /4/
  2616. C
  2617. C     Up arrow or keypad 8:
  2618.       IF (ICH.EQ.-1 .OR. ICH.EQ.-28) THEN
  2619.           ICY = ICY+STEP
  2620. C     Down arrow or keypad 2:
  2621.       ELSE IF (ICH.EQ.-2 .OR. ICH.EQ.-22) THEN
  2622.           ICY = ICY-STEP
  2623. C     Right arrow or keypad 6:
  2624.       ELSE IF (ICH.EQ.-3 .OR. ICH.EQ.-26) THEN
  2625.           ICX = ICX+STEP
  2626. C     Left arrow or keypad 4:
  2627.       ELSE IF (ICH.EQ.-4 .OR. ICH.EQ.-24) THEN
  2628.           ICX = ICX-STEP
  2629. C     Keypad 7 (left and up):
  2630.       ELSE IF (ICH.EQ.-27) THEN
  2631.           ICX = ICX-STEP
  2632.           ICY = ICY+STEP
  2633. C     Keypad 9 (right and up):
  2634.       ELSE IF (ICH.EQ.-29) THEN
  2635.           ICX = ICX+STEP
  2636.           ICY = ICY+STEP
  2637. C     Keypad 3 (right and down):
  2638.       ELSE IF (ICH.EQ.-23) THEN
  2639.           ICX = ICX+STEP
  2640.           ICY = ICY-STEP
  2641. C     Keypad 1 (left and down):
  2642.       ELSE IF (ICH.EQ.-21) THEN
  2643.           ICX = ICX-STEP
  2644.           ICY = ICY-STEP
  2645. C     PF1:
  2646.       ELSE IF (ICH.EQ.-11) THEN
  2647.           STEP = 1
  2648. C     PF2:
  2649.       ELSE IF (ICH.EQ.-12) THEN
  2650.           STEP = 4
  2651. C     PF3:
  2652.       ELSE IF (ICH.EQ.-13) THEN
  2653.           STEP = 16
  2654. C     PF4:
  2655.       ELSE IF (ICH.EQ.-14) THEN
  2656.           STEP = 64
  2657.       END IF
  2658.       END
  2659. C*GRMKER -- draw graph markers
  2660. C+
  2661.       SUBROUTINE GRMKER (SYMBOL,ABSXY,N,X,Y)
  2662. C
  2663. C GRPCKG: Draw a graph marker at a set of points in the current
  2664. C window. Line attributes (color, intensity, and  thickness)
  2665. C apply to markers, but line-style is ignored. After the call to
  2666. C GRMKER, the current pen position will be the center of the last
  2667. C marker plotted.
  2668. C
  2669. C Arguments:
  2670. C
  2671. C SYMBOL (input, integer): the marker number to be drawn. Numbers
  2672. C       0-31 are special marker symbols; numbers 32-127 are the
  2673. C       corresponding ASCII characters (in the current font). If the
  2674. C       number is >127, it is taken to be a Hershey symbol number.
  2675. C       If -ve, a regular polygon is drawn.
  2676. C ABSXY (input, logical): if .TRUE., the input corrdinates (X,Y) are
  2677. C       taken to be absolute device coordinates; if .FALSE., they are
  2678. C       taken to be world coordinates.
  2679. C N (input, integer): the number of points to be plotted.
  2680. C X, Y (input, real arrays, dimensioned at least N): the (X,Y)
  2681. C       coordinates of the points to be plotted.
  2682. C--
  2683. C (19-Mar-1983)
  2684. C 20-Jun-1985 - revise to window markers whole [TJP].
  2685. C  5-Aug-1986 - add GREXEC support [AFT].
  2686. C  1-Aug-1988 - add direct use of Hershey number [TJP].
  2687. C 15-Dec-1988 - standardize [TJP].
  2688. C 17-Dec-1990 - add polygons [PAH/TJP].
  2689. C 12-Jun-1992 - [TJP]
  2690. C 22-Sep-1992 - add support for hardware markers [TJP].
  2691. C  1-Sep-1994 - suppress driver call [TJP].
  2692. C 15-Feb-1994 - fix bug (expanding viewport!) [TJP].
  2693. C-----------------------------------------------------------------------
  2694.       INCLUDE 'f77.GRPCKG1/IN'
  2695.       INTEGER  SYMBOL
  2696.       INTEGER  C 
  2697.       LOGICAL  ABSXY, UNUSED, VISBLE
  2698.       INTEGER  I, K, LSTYLE, LX, LY, LXLAST, LYLAST, N, SYMNUM, NV
  2699.       INTEGER  XYGRID(300)
  2700.       REAL     ANGLE, COSA, SINA, FACTOR, RATIO, X(*), Y(*)
  2701.       REAL     XCUR, YCUR, XORG, YORG
  2702.       REAL     THETA, XOFF(40), YOFF(40), XP(40), YP(40)
  2703.       REAL     XMIN, XMAX, YMIN, YMAX
  2704.       REAL     XMINX, XMAXX, YMINX, YMAXX
  2705.       REAL     RBUF(4)
  2706.       INTEGER  NBUF,LCHR
  2707.       CHARACTER*32 CHR
  2708. C
  2709. C Check that there is something to be plotted.
  2710. C
  2711.       IF (N.LE.0) RETURN
  2712. C
  2713. C Check that a device is selected.
  2714. C
  2715.       IF (GRCIDE.LT.1) THEN
  2716.           CALL GRWARN('GRMKER - no graphics device is active.')
  2717.           RETURN
  2718.       END IF
  2719. C
  2720.       XMIN = GRXMIN(GRCIDE)
  2721.       XMAX = GRXMAX(GRCIDE)
  2722.       YMIN = GRYMIN(GRCIDE)
  2723.       YMAX = GRYMAX(GRCIDE)
  2724.       XMINX = XMIN-0.01
  2725.       XMAXX = XMAX+0.01
  2726.       YMINX = YMIN-0.01
  2727.       YMAXX = YMAX+0.01
  2728. C
  2729. C Does the device driver do markers (only markers 0-31 at present)?
  2730. C
  2731.       IF (GRGCAP(GRCIDE)(10:10).EQ.'M' .AND.
  2732.      :     SYMBOL.GE.0 .AND. SYMBOL.LE.31) THEN
  2733.           IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  2734. C         -- symbol number
  2735.           RBUF(1) = SYMBOL
  2736. C          -- scale factor
  2737.           RBUF(4) = GRCFAC(GRCIDE)/2.5
  2738.           NBUF = 4
  2739.           LCHR = 0
  2740.           DO 10 K=1,N
  2741. C             -- convert to device coordinates
  2742.               CALL GRTXY0(ABSXY, X(K), Y(K), XORG, YORG)
  2743. C             -- is the marker visible?
  2744.               CALL GRCLIP(XORG, YORG, XMINX, XMAXX, YMINX, YMAXX, C)
  2745.               IF (C.EQ.0) THEN
  2746.                   RBUF(2) = XORG
  2747.                   RBUF(3) = YORG
  2748.                   CALL GREXEC(GRGTYP,28,RBUF,NBUF,CHR,LCHR)
  2749.               END IF
  2750.    10     CONTINUE
  2751.           RETURN
  2752.       END IF
  2753. C
  2754. C Otherwise, draw the markers here.
  2755. C
  2756. C Save current line-style, and set style "normal".
  2757. C
  2758.       CALL GRQLS(LSTYLE)
  2759.       CALL GRSLS(1)
  2760. C
  2761. C Save current viewport, and open the viewport to include the full
  2762. C view surface.
  2763. C
  2764.       CALL GRAREA(GRCIDE, 0.0, 0.0, 0.0, 0.0)
  2765. C
  2766. C Compute scaling and orientation.
  2767. C
  2768.       ANGLE = 0.0
  2769.       FACTOR = GRCFAC(GRCIDE)/2.5
  2770.       RATIO = GRPXPI(GRCIDE)/GRPYPI(GRCIDE)
  2771.       COSA = FACTOR * COS(ANGLE)
  2772.       SINA = FACTOR * SIN(ANGLE)
  2773. C
  2774. C Convert the supplied marker number SYMBOL to a symbol number and
  2775. C obtain the digitization.
  2776. C
  2777.       IF (SYMBOL.GE.0) THEN
  2778.           IF (SYMBOL.GT.127) THEN
  2779.               SYMNUM = SYMBOL
  2780.           ELSE
  2781.               CALL GRSYMK(SYMBOL,GRCFNT(GRCIDE),SYMNUM)
  2782.           END IF
  2783.           CALL GRSYXD(SYMNUM, XYGRID, UNUSED)
  2784. C
  2785. C Positive symbols.
  2786. C
  2787.       DO 380 I=1,N
  2788.           CALL GRTXY0(ABSXY, X(I), Y(I), XORG, YORG)
  2789.           CALL GRCLIP(XORG, YORG, XMINX, XMAXX, YMINX, YMAXX, C)
  2790.           IF (C.NE.0) GOTO 380
  2791.           VISBLE = .FALSE.
  2792.           K = 4
  2793.           LXLAST = -64
  2794.           LYLAST = -64
  2795.   320       K = K+2
  2796.             LX = XYGRID(K)
  2797.             LY = XYGRID(K+1)
  2798.             IF (LY.EQ.-64) GOTO 380
  2799.             IF (LX.EQ.-64) THEN
  2800.                 VISBLE = .FALSE.
  2801.             ELSE
  2802.                 IF ((LX.NE.LXLAST) .OR. (LY.NE.LYLAST)) THEN
  2803.                     XCUR = XORG + (COSA*LX - SINA*LY)*RATIO
  2804.                     YCUR = YORG + (SINA*LX + COSA*LY)
  2805.                     IF (VISBLE) THEN
  2806.                         CALL GRLIN0(XCUR,YCUR)
  2807.                     ELSE
  2808.                         GRXPRE(GRCIDE) = XCUR
  2809.                         GRYPRE(GRCIDE) = YCUR
  2810.                     END IF
  2811.                 END IF
  2812.                 VISBLE = .TRUE.
  2813.                 LXLAST = LX
  2814.                 LYLAST = LY
  2815.             END IF
  2816.             GOTO 320
  2817.   380 CONTINUE
  2818. C
  2819. C Negative symbols.
  2820. C
  2821.       ELSE
  2822. C         ! negative symbol: filled polygon of radius 8
  2823.           NV = MIN(31,MAX(3,ABS(SYMBOL)))
  2824.           DO 400 I=1,NV
  2825.               THETA = 3.141592653*(REAL(2*(I-1))/REAL(NV) + 0.5) - ANGLE
  2826.               XOFF(I) = COS(THETA)*FACTOR*RATIO/GRXSCL(GRCIDE)*8.0
  2827.               YOFF(I) = SIN(THETA)*FACTOR/GRYSCL(GRCIDE)*8.0
  2828.   400     CONTINUE
  2829.           DO 420 K=1,N
  2830.               CALL GRTXY0(ABSXY, X(K), Y(K), XORG, YORG)
  2831.               CALL GRCLIP(XORG, YORG, XMINX, XMAXX, YMINX, YMAXX, C)
  2832.               IF (C.EQ.0) THEN
  2833.                   DO 410 I=1,NV
  2834.                       XP(I) = X(K)+XOFF(I)
  2835.                       YP(I) = Y(K)+YOFF(I)
  2836.   410             CONTINUE
  2837.                   CALL GRFA(NV, XP, YP)
  2838.               END IF
  2839.   420     CONTINUE
  2840.       END IF
  2841. C
  2842. C Set current pen position.
  2843. C
  2844.       GRXPRE(GRCIDE) = XORG
  2845.       GRYPRE(GRCIDE) = YORG
  2846. C
  2847. C Restore the viewport and line-style, and return.
  2848. C
  2849.       GRXMIN(GRCIDE) = XMIN
  2850.       GRXMAX(GRCIDE) = XMAX
  2851.       GRYMIN(GRCIDE) = YMIN
  2852.       GRYMAX(GRCIDE) = YMAX
  2853.       CALL GRSLS(LSTYLE)
  2854. C
  2855.       END
  2856.  
  2857. C*GRMOVA -- move pen (absolute, world coordinates)
  2858. C+
  2859.       SUBROUTINE GRMOVA (X,Y)
  2860. C
  2861. C GRPCKG: move the pen to a specified location.
  2862. C
  2863. C Arguments:
  2864. C
  2865. C X, Y (real, input): world coordinates of the new pen position.
  2866. C--
  2867. C (1-Feb-1983)
  2868. C-----------------------------------------------------------------------
  2869.       INCLUDE 'f77.GRPCKG1/IN'
  2870.       REAL     X,Y
  2871. C
  2872.       IF (GRCIDE.GE.1) THEN
  2873.           GRXPRE(GRCIDE) = X * GRXSCL(GRCIDE) + GRXORG(GRCIDE)
  2874.           GRYPRE(GRCIDE) = Y * GRYSCL(GRCIDE) + GRYORG(GRCIDE)
  2875.       END IF
  2876.       END
  2877.  
  2878. C*GRMOVR -- move pen (relative, world coordinates)
  2879. C+
  2880.       SUBROUTINE GRMOVR (DX,DY)
  2881. C
  2882. C GRPCKG: move the pen through a specified displacement.
  2883. C
  2884. C Arguments:
  2885. C
  2886. C DX, DY (real, input): the displacement in world coordinates: the pen
  2887. C       position is incremented by DX in x and DY in y.
  2888. C--
  2889. C (1-Feb-1983)
  2890. C-----------------------------------------------------------------------
  2891.       INCLUDE 'f77.GRPCKG1/IN'
  2892.       REAL     DX,DY
  2893. C
  2894.       IF (GRCIDE.GE.1) THEN
  2895.           GRXPRE(GRCIDE) = GRXPRE(GRCIDE) + DX*GRXSCL(GRCIDE)
  2896.           GRYPRE(GRCIDE) = GRYPRE(GRCIDE) + DY*GRYSCL(GRCIDE)
  2897.       END IF
  2898.       END
  2899. C*GRMSG -- issue message to user
  2900. C+
  2901.       SUBROUTINE GRMSG (TEXT)
  2902.       CHARACTER*(*) TEXT
  2903. C
  2904. C Display a message on standard output.
  2905. C
  2906. C Argument:
  2907. C  TEXT (input): text of message to be printed (the string
  2908. C      may not be blank).
  2909. C--
  2910. C  8-Nov-1994 [TJP].
  2911. C-----------------------------------------------------------------------
  2912.       INTEGER   GRTRIM
  2913. C
  2914.       IF (TEXT.NE.' ') THEN
  2915.           WRITE (*, '(1X,A)') TEXT(1:GRTRIM(TEXT))
  2916.       END IF
  2917.       END
  2918. C*GROPEN -- open device for graphics
  2919. C+
  2920.       INTEGER FUNCTION GROPEN (TYPE,DUMMY,FILE,IDENT)
  2921.       INTEGER   TYPE, DUMMY, IDENT
  2922.       CHARACTER*(*) FILE
  2923. C
  2924. C GRPCKG: assign a device and prepare for plotting.  GROPEN must be
  2925. C called before all other calls to GRPCKG routines.
  2926. C
  2927. C Returns:
  2928. C
  2929. C GROPEN (output, integer): 1 => success, any other value
  2930. C       indicates a failure (usually the value returned will
  2931. C       be a VMS error code). In the event of an error, a
  2932. C       message will be sent to the standard error unit.
  2933. C
  2934. C Arguments:
  2935. C
  2936. C TYPE (input, integer): default device type (integer code).
  2937. C DUMMY (input, integer): not used at present.
  2938. C FILE (input, character): plot specifier, of form 'device/type'.
  2939. C IDENT (output, integer): plot identifier to be used in later
  2940. C       calls to GRPCKG.
  2941. C
  2942. C  1-Jun-1984 - [TJP].
  2943. C  2-Jul-1984 - change to call GRSLCT [TJP].
  2944. C 13-Jul-1984 - add device initialization [TJP].
  2945. C 23-Jul-1984 - add /APPEND qualifier.
  2946. C 19-Oct-1984 - add VV device [TJP].
  2947. C 26-Dec-1984 - obtain default file name from common [TJP].
  2948. C 29-Jan-1985 - add HP2648 device [KS/TJP].
  2949. C  5-Aug-1986 - add GREXEC support [AFT].
  2950. C 12-Oct-1986 - fix bug causing GREXEC to erase screen [AFT].
  2951. C  3-Jun-1987 - remove declaration of exit handler [TJP].
  2952. C 15-Dec-1988 - standardize [TJP].
  2953. C 25-Jun-1989 - remove code that removes spaces from the device name 
  2954. C               [TJP].
  2955. C 26-Nov-1990 - [TJP].
  2956. C  5-Jan-1993 - [TJP].
  2957. C  1-Sep-1994 - store device capabilities in common for later use [TJP].
  2958. C 17-Apr-1995 - zero-length string fix [TJP].
  2959. C  6-Jun-1995 - explicitly initialize GRSTAT [TJP].
  2960. C 29-Apr-1996 - moved initialization into GRINIT [TJP].
  2961. C-----------------------------------------------------------------------
  2962.       INCLUDE 'f77.GRPCKG1/IN'
  2963.       INTEGER   IER, FTYPE, NBUF, LCHR
  2964.       INTEGER   GRPARS, GRTRIM
  2965.       REAL      RBUF(6)
  2966.       LOGICAL   APPEND
  2967.       CHARACTER*128 FFILE,CHR
  2968. C
  2969. C Initialize GRPCKG; read font file (if necessary).
  2970. C
  2971.       CALL GRINIT
  2972. C
  2973. C Allocate an identifier.
  2974. C
  2975.       IDENT = 1
  2976.    10 IF (GRSTAT(IDENT).NE.0) THEN
  2977.           IDENT = IDENT+1
  2978.           IF (IDENT.GT.GRIMAX) THEN
  2979.               CALL GRWARN('Too many active plots.')
  2980.               GROPEN = -1
  2981.               IDENT = 0
  2982.               RETURN
  2983.           END IF
  2984.       GOTO 10
  2985.       END IF
  2986. C
  2987. C Validate the device specification.
  2988. C
  2989.       IER = GRPARS(FILE,FFILE,FTYPE,APPEND)
  2990.       IF (IER.NE.1) THEN
  2991.           CHR = 'Invalid device specification: '
  2992.           CHR(31:) = FILE
  2993.           CALL GRWARN(CHR)
  2994.           GROPEN = -1
  2995.           RETURN
  2996.       END IF
  2997.       IF (FTYPE.EQ.0) FTYPE = TYPE
  2998.       IF (1.LE.FTYPE) THEN
  2999.           GRTYPE(IDENT) = FTYPE
  3000.           GRGTYP = FTYPE
  3001.       ELSE
  3002.           CHR = 'Device type omitted or invalid: '
  3003.           CHR(33:) = FILE
  3004.           CALL GRWARN(CHR)
  3005.           GROPEN = -1
  3006.           RETURN
  3007.       END IF
  3008. C
  3009. C Install the file name, or assign default.
  3010. C
  3011.       IF (FFILE.EQ.' ') THEN
  3012.           CALL GREXEC(GRGTYP, 5,RBUF,NBUF,FFILE,LCHR)
  3013.       END IF
  3014.       GRFILE(IDENT) = FFILE
  3015.       GRFNLN(IDENT) = MAX(1,GRTRIM(GRFILE(IDENT)))
  3016. C
  3017. C Open workstation.
  3018. C
  3019.       RBUF(3)=0
  3020.       IF (APPEND) RBUF(3)=1
  3021.       NBUF=3
  3022.       CALL GREXEC(GRGTYP, 9,RBUF,NBUF, GRFILE(IDENT),GRFNLN(IDENT))
  3023.       GRUNIT(IDENT)=RBUF(1)
  3024.       GROPEN=RBUF(2)
  3025.       IF (GROPEN.NE.1) RETURN
  3026.       GRPLTD(IDENT) = .FALSE.
  3027.       GRSTAT(IDENT) = 1
  3028.       CALL GRSLCT(IDENT)
  3029. C
  3030. C Install the default plot parameters
  3031. C
  3032. C--- Inquire color-index range.
  3033.       CALL GREXEC(GRGTYP, 2,RBUF,NBUF,CHR,LCHR)
  3034.       GRMNCI(IDENT)=RBUF(5)
  3035.       GRMXCI(IDENT)=RBUF(6)
  3036. C--- Inquire resolution.
  3037.       CALL GREXEC(GRGTYP, 3,RBUF,NBUF,CHR,LCHR)
  3038.       GRPXPI(IDENT)=RBUF(1)
  3039.       GRPYPI(IDENT)=RBUF(2)
  3040. C--- Inquire default character size.
  3041.       CALL GREXEC(GRGTYP, 7,RBUF,NBUF,CHR,LCHR)
  3042.       GRCSCL(IDENT) = RBUF(1)
  3043.       GRCFAC(IDENT) = RBUF(1)
  3044. C--- Inquire default plot size.
  3045.       CALL GREXEC(GRGTYP, 6,RBUF,NBUF,CHR,LCHR)
  3046.       GRXMXA(IDENT) = RBUF(2)
  3047.       GRYMXA(IDENT) = RBUF(4)
  3048.       GRXMIN(IDENT) = RBUF(1)
  3049.       GRXMAX(IDENT) = RBUF(2)
  3050.       GRYMIN(IDENT) = RBUF(3)
  3051.       GRYMAX(IDENT) = RBUF(4)
  3052. C--- Inquire device capabilities.
  3053.       CALL GREXEC(GRGTYP, 4,RBUF,NBUF,CHR,LCHR)
  3054.       GRGCAP(IDENT) = CHR(:LCHR)
  3055. C--- Current pen position.
  3056.       GRXPRE(IDENT) = 0.0
  3057.       GRYPRE(IDENT) = 0.0
  3058. C--- GRSETS has not been called.
  3059.       GRADJU(IDENT) = .FALSE.
  3060. C---Default scaling.
  3061.       CALL GRTRN0(0.0, 0.0, 1.0, 1.0)
  3062. C
  3063. C Default attributes.
  3064. C  text font (normal)
  3065. C  color (white)
  3066. C  line-style (full)
  3067. C  line-width (minimum)
  3068. C  marker number (dot)
  3069. C
  3070.       GRCFNT(IDENT) = 1
  3071.       GRCCOL(IDENT) = 1
  3072.       GRSTYL(IDENT) = 1
  3073.       GRWIDT(IDENT) = 1
  3074.       GRCMRK(IDENT) = 1
  3075.       GRDASH(IDENT) = .FALSE.
  3076. C
  3077.       GROPEN = 1
  3078. C
  3079.       END
  3080. C*GRPAGE -- end picture
  3081. C+
  3082.       SUBROUTINE GRPAGE
  3083. C
  3084. C GRPCKG: Advance the plotting area to a new page. For video devices,
  3085. C this amounts to erasing the screen; for hardcopy devices, the plot
  3086. C buffer is written to the output file followed by a form-feed to
  3087. C advance the paper to the start of the next page.
  3088. C
  3089. C Arguments: none.
  3090. C--
  3091. C  3-Jun-1983 - [TJP].
  3092. C 18-Feb-1984 - remove unnecessary 'T' initialization of VT125, and add
  3093. C               S(G1) for Rainbow REGIS [TJP].
  3094. C  1-Jun-1984 - add type GMFILE [TJP].
  3095. C  2-Jul-1984 - change initialization of VT125 for color [TJP].
  3096. C 13-Jul-1984 - move initialization of VT125 and Grinnell to GROPEN
  3097. C               [TJP].
  3098. C 19-Oct-1984 - add VV device [TJP].
  3099. C 29-Jan-1985 - add HP2648 terminal [KS/TJP].
  3100. C  5-Aug-1986 - add GREXEC support [AFT].
  3101. C 21-Feb-1987 - fix GREXEC end picture sequence [AFT].
  3102. C 11-Jun-1987 - remove built-in devices [TJP].
  3103. C 11-Feb-1992 - update veiew surface size: it may have changed! [TJP].
  3104. C  5-Jan-1993 - but only if GRSETS has not been called! [TJP]
  3105. C-----------------------------------------------------------------------
  3106.       INCLUDE 'f77.GRPCKG1/IN'
  3107. C
  3108.       INTEGER NBUF,LCHR
  3109.       REAL    RBUF(6)
  3110. C
  3111.       CHARACTER CHR
  3112. C
  3113. C Flush the buffer.
  3114. C
  3115.       CALL GRTERM
  3116. C
  3117. C Erase the text screen (if there is one).
  3118. C
  3119.       CALL GRETXT
  3120. C
  3121. C End picture.
  3122. C
  3123.       CALL GREPIC
  3124. C
  3125. C Update the view surface size: it may have changed (on windowing 
  3126. C devices)
  3127. C
  3128.       IF (.NOT.GRADJU(GRCIDE)) THEN
  3129.           CALL GREXEC(GRGTYP, 6,RBUF,NBUF,CHR,LCHR)
  3130.           GRXMXA(GRCIDE) = RBUF(2)
  3131.           GRYMXA(GRCIDE) = RBUF(4)
  3132.       END IF
  3133. C
  3134.       END
  3135. C*GRPARS -- parse device specification string
  3136. C+
  3137.       INTEGER FUNCTION GRPARS (SPEC,DEV,TYPE,APPEND)
  3138.       CHARACTER*(*) SPEC, DEV
  3139.       INTEGER  TYPE
  3140.       LOGICAL  APPEND
  3141. C
  3142. C GRPCKG: decode a device-specification; called by GROPEN.
  3143. C
  3144. C Returns:
  3145. C  GRPARS (output): 1 if the device-specification is
  3146. C       acceptable; any other value indicates an error.
  3147. C
  3148. C Arguments:
  3149. C  SPEC (input): the device specification.
  3150. C  DEV  (output):  device name or file spec.
  3151. C  TYPE (output): device type (integer code); 0 if no device
  3152. C       type is specified.
  3153. C  APPEND (output): .TRUE. if /APPEND specified, .FALSE. otherwise.
  3154. C--
  3155. C 23-Jul-1984 - [TJP].
  3156. C 19-Feb-1988 - allow device part to be quoted [TJP].
  3157. C 30-Mar-1989 - remove logical translation of device and type [TJP].
  3158. C 17-Jun-1991 - ignore comments after ' (' [TJP].
  3159. C 19-Dec-1994 - rewritten to scan backwards [TJP].
  3160. C  6-Jun-1995 - correct a zero-length string problem [TJP].
  3161. C-----------------------------------------------------------------------
  3162.       CHARACTER*32  CTYPE, UPPER
  3163.       CHARACTER*6   APPSTR
  3164.       CHARACTER*256 DESCR
  3165.       INTEGER       GRDTYP, GRTRIM
  3166.       INTEGER       L, LC, LS
  3167.       DATA          APPSTR/'APPEND'/
  3168. C
  3169. C Default results.
  3170. C
  3171.       DEV = ' '
  3172.       TYPE = 0
  3173.       APPEND = .FALSE.
  3174.       GRPARS = 1
  3175.       CTYPE = ' '
  3176. C
  3177. C Null string is acceptable.
  3178. C
  3179.       IF (LEN(SPEC).LT.1) RETURN
  3180.       IF (SPEC.EQ.' ') RETURN
  3181. C
  3182. C On systems where it is possible, perform a "logical name" translation.
  3183. C
  3184.       DESCR = SPEC
  3185.       CALL GRLGTR(DESCR)
  3186. C
  3187. C Discard trailing blanks: L is length of remainder.
  3188. C
  3189.       L = GRTRIM(DESCR)
  3190. C
  3191. C Find last slash in string (position LS or 0).
  3192. C
  3193.       LS = L
  3194.  20   IF (DESCR(LS:LS).NE.'/') THEN
  3195.          LS = LS-1
  3196.          IF (LS.GT.0) GOTO 20
  3197.       END IF
  3198. C
  3199. C Check for /APPEND qualifier; if present, look again for type.
  3200. C
  3201.       IF (LS.GT.0) THEN
  3202.          CTYPE = DESCR(LS+1:L)
  3203.          CALL GRTOUP(UPPER,CTYPE)
  3204.          CTYPE = UPPER
  3205.          IF (CTYPE.EQ.APPSTR) THEN
  3206.             APPEND = .TRUE.
  3207.             L = LS-1
  3208.             LS = L
  3209.  30         IF (DESCR(LS:LS).NE.'/') THEN
  3210.                LS = LS-1
  3211.                IF (LS.GT.0) GOTO 30
  3212.             END IF
  3213.          ELSE
  3214.             APPEND = .FALSE.
  3215.          END IF
  3216.       END IF
  3217. C
  3218. C If LS=0 there is no type field: use PGPLOT_TYPE.
  3219. C
  3220.       IF (LS.EQ.0) THEN
  3221.          CALL GRGENV('TYPE', CTYPE, LC)
  3222.       ELSE
  3223.          CTYPE = DESCR(LS+1:L)
  3224.          LC = L-LS
  3225.          L = LS-1
  3226.       END IF
  3227. C
  3228. C Check for allowed type.
  3229. C
  3230.       IF (LC.GT.0) THEN
  3231.          CALL GRTOUP(UPPER,CTYPE)
  3232.          CTYPE = UPPER
  3233.          TYPE = GRDTYP(CTYPE)
  3234.          IF (TYPE.EQ.0) CALL GRWARN('Unrecognized device type')
  3235.          IF (TYPE.EQ.-1) CALL GRWARN('Device type is ambiguous')
  3236.       ELSE
  3237.          TYPE = 0
  3238.          CALL GRWARN('Device type omitted')
  3239.       END IF
  3240.       IF (TYPE.EQ.0) GRPARS = GRPARS+2
  3241. C
  3242. C Remove quotes from device if necessary.
  3243. C
  3244.       IF (L.GE.1) THEN
  3245.          IF (DESCR(1:1).EQ.'"' .AND. DESCR(L:L).EQ.'"') THEN
  3246.             DEV = DESCR(2:L-1)
  3247.             L = L-2
  3248.          ELSE
  3249.             DEV = DESCR(1:L)
  3250.          END IF
  3251.       END IF
  3252. C
  3253. C      write (*,*) 'Device = [', DEV(1:L), ']'
  3254. C      write (*,*) 'Type   = [', CTYPE, ']', TYPE
  3255. C      write (*,*) 'APPEND = ', APPEND
  3256. C
  3257.       END
  3258. C*GRPIXL -- solid-fill multiple rectangular areas
  3259. C+
  3260.       SUBROUTINE GRPIXL (IA, IDIM, JDIM, I1, I2, J1, J2, 
  3261.      1                   X1, X2, Y1, Y2)
  3262.       INTEGER IDIM, JDIM, I1, I2, J1, J2
  3263.       INTEGER IA(IDIM,JDIM)
  3264.       REAL    X1, X2, Y1, Y2
  3265. C
  3266. C Determine the size of each rectangular element. If it is equal
  3267. C to the device pen width and the device supports pixel primitives,
  3268. C use pixel primitives. Otherwise, if the size is smaller than the
  3269. C device pen width emulate pixel output by plotting points. If the
  3270. C size is larger than the device pen width, emulate by outputting
  3271. C solid-filled rectangles.
  3272. C
  3273. C Arguments:
  3274. C  IA     (input)  : the array to be plotted.
  3275. C  IDIM   (input)  : the first dimension of array A.
  3276. C  JDIM   (input)  : the second dimension of array A.
  3277. C  I1, I2 (input)  : the inclusive range of the first index
  3278. C                    (I) to be plotted.
  3279. C  J1, J2 (input)  : the inclusive range of the second
  3280. C                    index (J) to be plotted.
  3281. C  X1, Y1 (input)  : world coordinates of one corner of the output
  3282. C                    region
  3283. C  X2, Y2 (input)  : world coordinates of the opposite corner of the
  3284. C                    output region
  3285. C--
  3286. C 18-Jan-1991 - [Ge van Geldorp]
  3287. C 31-Mar-1993 - Include color PostScript GRPXPS [Remko Scharroo]
  3288. C  4-Apr-1993 - New version of GRPXPS incorporated
  3289. C  4-Aug-1993 - Debugging
  3290. C  7-Sep-1994 - Revised for v5.0 [TJP].
  3291. C 24-Jan-1996 - GRXMIN etc changed to REAL as required in f77.GRPCKG1/IN [RS]
  3292. C-----------------------------------------------------------------------
  3293.       INCLUDE 'f77.GRPCKG1/IN'
  3294.       REAL    RBUF(3)
  3295.       INTEGER NBUF, LCHR
  3296.       CHARACTER*32 CHR
  3297.       REAL    XLL, YLL, XUR, YUR
  3298.       REAL    XMIN, YMIN, XMAX, YMAX, XPIX, YPIX
  3299.       REAL    WIDTH, XSIZE, YSIZE
  3300.       INTEGER IL, IR, JB, JT
  3301. C
  3302.       IF (GRCIDE.LT.1) RETURN
  3303. C
  3304. C Convert to device coordinates
  3305. C
  3306.       CALL GRTXY0(.FALSE., X1, Y1, XLL, YLL)
  3307.       CALL GRTXY0(.FALSE., X2, Y2, XUR, YUR)
  3308.       XMIN = MIN(XLL,XUR)
  3309.       XMAX = MAX(XLL,XUR)
  3310.       YMIN = MIN(YLL,YUR)
  3311.       YMAX = MAX(YLL,YUR)
  3312. C
  3313. C Check if completely outside clipping region
  3314. C
  3315.       IF (XMAX .LT. GRXMIN(GRCIDE) .OR. GRXMAX(GRCIDE) .LT. XMIN .OR.
  3316.      1    YMAX .LT. GRYMIN(GRCIDE) .OR. GRYMAX(GRCIDE) .LT. YMIN)
  3317.      2   RETURN
  3318. C
  3319. C Don't paint "pixels" completely before left clipping boundary
  3320. C
  3321.       XPIX = XMAX - XMIN
  3322.       YPIX = YMAX - YMIN
  3323.       IF (XMIN .LT. GRXMIN(GRCIDE)) THEN
  3324.          IL = I1 + (GRXMIN(GRCIDE) - XMIN) * (I2 - I1 + 1) / XPIX
  3325.          XMIN = XMIN + (XPIX * (IL - I1)) / (I2 - I1 + 1)
  3326.       ELSE
  3327.          IL = I1
  3328.       ENDIF
  3329. C
  3330. C Don't paint "pixels" completely after right clipping boundary
  3331. C
  3332.       IF (GRXMAX(GRCIDE) .LT. XMAX) THEN
  3333.          IR = I2 - (XMAX - GRXMAX(GRCIDE)) * (I2 - I1 + 1) / XPIX + 1
  3334.          XMAX = XMIN + (XPIX * (IR - I1 + 1)) /
  3335.      1                 (I2 - I1 + 1)
  3336.       ELSE
  3337.          IR = I2
  3338.       ENDIF
  3339. C
  3340. C Don't paint "pixels" completely under bottom clipping boundary
  3341. C
  3342.       IF (YMIN .LT. GRYMIN(GRCIDE)) THEN
  3343.          JB = J1 + (GRYMIN(GRCIDE) - YMIN) * (J2 - J1 + 1) / YPIX
  3344.          YMIN = YMIN + (YPIX * (JB - J1)) / (J2 - J1 + 1)
  3345.       ELSE
  3346.          JB = J1
  3347.       ENDIF
  3348. C
  3349. C Don't paint "pixels" completely above top clipping boundary
  3350. C
  3351.       IF (GRYMAX(GRCIDE) .LT. YMAX) THEN
  3352.          JT = J2 - (YMAX - GRYMAX(GRCIDE)) * (J2 - J1 + 1) / YPIX + 1
  3353.          YMAX = YMIN + (YPIX * (JT - J1 + 1)) /
  3354.      1                 (J2 - J1 + 1)
  3355.       ELSE
  3356.          JT = J2
  3357.       ENDIF
  3358. C
  3359. C If device accepts image primitives, use GRPXPS
  3360. C
  3361.       IF (GRGCAP(GRCIDE)(7:7).EQ.'Q') THEN
  3362.          CALL GRPXPS(IA, IDIM, JDIM, IL, IR, JB, JT,
  3363.      1             XMIN,XMAX,YMIN,YMAX)
  3364.          RETURN
  3365.       ENDIF
  3366. C
  3367. C Check against pen width
  3368. C
  3369.       CALL GREXEC(GRGTYP, 3, RBUF, NBUF, CHR, LCHR)
  3370.       WIDTH = RBUF(3)
  3371.       XSIZE = (I2 - I1 + 1) * WIDTH
  3372.       YSIZE = (J2 - J1 + 1) * WIDTH
  3373.       XPIX = XMAX - XMIN + 1
  3374.       YPIX = YMAX - YMIN + 1
  3375. C
  3376. C Use rectangles if "pixel" is too large
  3377. C
  3378.       IF (XPIX .GT. XSIZE + 0.5 * WIDTH .OR.
  3379.      1    YPIX .GT. YSIZE + 0.5 * WIDTH) THEN
  3380. *     write (6,*) 'GRPXRE'
  3381.          CALL GRPXRE(IA, IDIM, JDIM, IL, IR, JB, JT,
  3382.      1             XMIN, XMAX, YMIN, YMAX)
  3383. C
  3384. C Use either pixel primitives or points
  3385. C
  3386.       ELSE
  3387. C
  3388. C Clip pixels lying more than 50% outside clipping boundaries
  3389. C
  3390.          IF (XMIN .LT. GRXMIN(GRCIDE) - 0.5 * WIDTH) THEN
  3391.             XMIN = XMIN + XPIX / (IR - IL + 1)
  3392.             IL = IL + 1
  3393.          ENDIF
  3394.          IF (GRXMAX(GRCIDE) + 0.5 * WIDTH .LT. XMAX) THEN
  3395.             XMAX = XMAX - XPIX / (IR - IL + 1)
  3396.             IR = IR - 1
  3397.          ENDIF
  3398.          IF (YMIN .LT. GRYMIN(GRCIDE) - 0.5 * WIDTH) THEN
  3399.             YMIN = YMIN + YPIX / (JT - JB + 1)
  3400.             JB = JB + 1
  3401.          ENDIF
  3402.          IF (GRYMAX(GRCIDE) + 0.5 * WIDTH .LT. YMAX) THEN
  3403.             YMAX = YMAX - YPIX / (JT - JB + 1)
  3404.             JT = JT - 1
  3405.          ENDIF
  3406. C
  3407. C Recalculate size
  3408. C
  3409.          XSIZE = (IR - IL + 1) * WIDTH
  3410.          YSIZE = (JT - JB + 1) * WIDTH
  3411.          XPIX = XMAX - XMIN + 1
  3412.          YPIX = YMAX - YMIN + 1
  3413. C
  3414. C Use pixel primitives if available and possible
  3415. C
  3416.          IF (GRGCAP(GRCIDE)(7:7) .EQ. 'P' .AND. 
  3417.      1       XSIZE - 0.5 * WIDTH .LE. XPIX .AND.
  3418.      2       YSIZE - 0.5 * WIDTH .LE. YPIX) THEN
  3419. *     write (6,*) 'GRPXPX'
  3420.             CALL GRPXPX(IA, IDIM, JDIM, IL, IR, JB, JT, XMIN, YMIN)
  3421. C
  3422. C Otherwise, use points
  3423. C
  3424.          ELSE
  3425. *     write (6,*) 'GRPXPO'
  3426.             CALL GRPXPO(IA, IDIM, JDIM, IL, IR, JB, JT,
  3427.      1             XMIN, XMAX, YMIN, YMAX)
  3428.          ENDIF
  3429.       ENDIF
  3430.       END
  3431. C*GRPOCL -- polygon clip
  3432. C+
  3433.       SUBROUTINE GRPOCL (N,PX,PY, EDGE, VAL, MAXOUT, NOUT, QX, QY)
  3434.       INTEGER N, NOUT, EDGE, MAXOUT
  3435.       REAL    PX(*), PY(*), QX(*), QY(*)
  3436.       REAL    VAL
  3437. C
  3438. C Clip a polygon against a rectangle: Sutherland-Hodgman algorithm.
  3439. C this routine must be called four times to clip against each of the
  3440. C edges of the rectangle in turn.      
  3441. C
  3442. C Arguments:
  3443. C
  3444. C N (input, integer): the number of vertices of the polygon (at least
  3445. C       3).
  3446. C PX, PY (input, real arrays, dimension at least N): world coordinates
  3447. C       of the N vertices of the input polygon.
  3448. C EDGE (input, integer):
  3449. C     1: clip against left edge,   X > XMIN=VAL
  3450. C     2: clip against right edge,  X < XMAX=VAL
  3451. C     3: clip against bottom edge, Y > YMIN=VAL
  3452. C     4: clip against top edge,    Y < YMIN=VAL
  3453. C VAL  (input, real): coordinate value of current edge.
  3454. C MAXOUT (input, integer): maximum number of vertices allowed in
  3455. C     output polygon (dimension of QX, QY).
  3456. C NOUT (output, integer): the number of vertices in the clipped polygon.
  3457. C QX, QY (output, real arrays, dimension at least MAXOUT): world
  3458. C       coordinates of the NOUT vertices of the output polygon.
  3459. C--
  3460. C 19-Sep-1994 - [TJP].
  3461. C 27-Feb-1996 - fix bug: overflow if coordinates are large [TJP].
  3462. C 11-Jul-1996 - fix bug: left and bottom edges disappeared when precisely
  3463. C               on edge [Remko Scharroo]
  3464. C-----------------------------------------------------------------------
  3465.       INTEGER I
  3466.       REAL FX, FY, SX, SY
  3467. C
  3468.       NOUT = 0
  3469.       DO 100 I=1,N
  3470.          IF (I.EQ.1) THEN
  3471. C           -- save first point
  3472.             FX = PX(I)
  3473.             FY = PY(I)
  3474.          ELSE IF ((EDGE.EQ.1 .OR.EDGE.EQ.2) .AND.
  3475.      :            (SIGN(1.0,PX(I)-VAL).NE.SIGN(1.0,SX-VAL))) THEN
  3476. C           -- SP intersects this edge: output vertex at intersection
  3477.             NOUT = NOUT+1
  3478.             IF (NOUT.LE.MAXOUT) THEN
  3479.                QX(NOUT) = VAL
  3480.                QY(NOUT) = SY + (PY(I)-SY)*((VAL-SX)/(PX(I)-SX))
  3481.             END IF
  3482.          ELSE IF ((EDGE.EQ.3 .OR.EDGE.EQ.4) .AND.
  3483.      :            (SIGN(1.0,PY(I)-VAL).NE.SIGN(1.0,SY-VAL))) THEN
  3484. C           -- SP intersects this edge: output vertex at intersection
  3485.             NOUT = NOUT+1
  3486.             IF (NOUT.LE.MAXOUT) THEN
  3487.                QX(NOUT) = SX + (PX(I)-SX)*((VAL-SY)/(PY(I)-SY))
  3488.                QY(NOUT) = VAL
  3489.             END IF
  3490.          END IF
  3491.          SX = PX(I)
  3492.          SY = PY(I)
  3493.          IF ((EDGE.EQ.1.AND.SX.GE.VAL) .OR.
  3494.      :       (EDGE.EQ.2.AND.SX.LE.VAL) .OR.
  3495.      :       (EDGE.EQ.3.AND.SY.GE.VAL) .OR.
  3496.      :       (EDGE.EQ.4.AND.SY.LE.VAL)) THEN
  3497. C           -- output visible vertex S
  3498.             NOUT = NOUT + 1
  3499.             IF (NOUT.LE.MAXOUT) THEN
  3500.                 QX(NOUT) = SX
  3501.                 QY(NOUT) = SY
  3502.             END IF
  3503.          END IF
  3504.  100  CONTINUE
  3505. C      -- Does SF intersect edge?
  3506.       IF ((EDGE.EQ.1 .OR. EDGE.EQ.2) .AND.
  3507.      :    (SIGN(1.0,SX-VAL).NE.SIGN(1.0,FX-VAL))) THEN
  3508.          NOUT = NOUT+1
  3509.          IF (NOUT.LE.MAXOUT) THEN
  3510.             QX(NOUT) = VAL
  3511.             QY(NOUT) = SY + (FY-SY)*((VAL-SX)/(FX-SX))
  3512.          END IF
  3513.       ELSE IF ((EDGE.EQ.3 .OR. EDGE.EQ.4) .AND.
  3514.      :         (SIGN(1.0,SY-VAL).NE.SIGN(1.0,FY-VAL))) THEN
  3515.          NOUT = NOUT+1
  3516.          IF (NOUT.LE.MAXOUT) THEN
  3517.             QY(NOUT) = VAL
  3518.             QX(NOUT) = SX + (FX-SX)*((VAL-SY)/(FY-SY))
  3519.          END IF
  3520.       END IF
  3521. C
  3522.       END
  3523. C*GRPROM -- prompt user before clearing screen
  3524. C+
  3525.       SUBROUTINE GRPROM
  3526. C
  3527. C If the program is running under control of a terminal, display
  3528. C message and wait for the user to type <CR> before proceeding.
  3529. C
  3530. C Arguments:
  3531. C  none
  3532. C--
  3533. C 18-Aug-1994
  3534. C-----------------------------------------------------------------------
  3535.       INTEGER IER, L, GRGCOM
  3536.       CHARACTER*16 JUNK
  3537. C
  3538.       IER = GRGCOM(JUNK, 'Type <RETURN> for next page: ', L)
  3539.       END
  3540. C*GRPXPO -- Emulate pixel operations using points
  3541. C+
  3542.       SUBROUTINE GRPXPO (IA, IDIM, JDIM, I1, I2, J1, J2, 
  3543.      1                   X1, X2, Y1, Y2)
  3544.       INTEGER IDIM, JDIM, I1, I2, J1, J2
  3545.       INTEGER IA(IDIM,JDIM)
  3546.       REAL    X1, X2, Y1, Y2
  3547. C
  3548. C Arguments:
  3549. C  IA     (input)  : the array to be plotted.
  3550. C  IDIM   (input)  : the first dimension of array A.
  3551. C  JDIM   (input)  : the second dimension of array A.
  3552. C  I1, I2 (input)  : the inclusive range of the first index
  3553. C                    (I) to be plotted.
  3554. C  J1, J2 (input)  : the inclusive range of the second
  3555. C                    index (J) to be plotted.
  3556. C  X1, X2 (input)  : the horizontal range of the output region
  3557. C  Y1, Y2 (input)  : the vertical range of the output region
  3558. C--
  3559. C 16-Jan-1991 - [GvG]
  3560. C 28-Jun-1991
  3561. C-----------------------------------------------------------------------
  3562.       INCLUDE 'f77.GRPCKG1/IN'
  3563.       INTEGER LW
  3564.       INTEGER I, J
  3565.       INTEGER ICOL, LSTCOL
  3566. C
  3567. C Save attributes
  3568. C
  3569.       CALL GRQLW(LW)
  3570.       CALL GRQCI(ICOL)
  3571.       CALL GRSLW(1)
  3572.       LSTCOL = ICOL
  3573.       DO 20 J = J1, J2
  3574.          DO 10 I = I1, I2
  3575. C
  3576. C Color changed?
  3577. C
  3578.             IF (IA(I, J) .NE. LSTCOL) THEN
  3579.                CALL GRSCI(IA(I, J))
  3580.                LSTCOL = IA(I, J)
  3581.             ENDIF
  3582. C
  3583. C Output dot
  3584. C
  3585.             CALL GRDOT0(X1 + (X2 - X1) * (I - I1 + 0.5) / (I2 - I1 + 1),
  3586.      1                  Y1 + (Y2 - Y1) * (J - J1 + 0.5) / (J2 - J1 + 1))
  3587.   10     CONTINUE
  3588.   20  CONTINUE
  3589. C
  3590. C Restore attributes
  3591. C
  3592.       CALL GRSCI(ICOL)
  3593.       CALL GRSLW(LW)
  3594.       END
  3595. C*GRPXPS -- pixel dump for color or grey PostScript.
  3596. C+
  3597.       SUBROUTINE GRPXPS (IA, IDIM, JDIM, I1, I2, J1, J2,
  3598.      :                   XMIN, XMAX, YMIN, YMAX)
  3599.       INTEGER IDIM, JDIM, I1, I2, J1, J2
  3600.       INTEGER IA(IDIM,JDIM)
  3601.       REAL XMIN, XMAX, YMIN, YMAX
  3602. C
  3603. C This routine is called by GRPIXL.
  3604. C--
  3605. C  4-Apr-93 - Created from GRGRAY by Remko Scharroo - DUT/SSRT
  3606. C  8-Apr-93 - Bugs fixed.
  3607. C  6-Jul-94 - Aligned with PGPLOT V4.9H
  3608. C  7-Sep-94 - updated for V5.0 [TJP].
  3609. C-----------------------------------------------------------------------
  3610.       INCLUDE 'f77.GRPCKG1/IN'
  3611.       INTEGER  I, J, NXP, NYP, NBUF, LCHR, II
  3612.       REAL     DX,DY,RBUF(32)
  3613.       CHARACTER*32 CHR
  3614. C-----------------------------------------------------------------------
  3615.       NXP = I2 - I1 + 1
  3616.       NYP = J2 - J1 + 1
  3617. C
  3618. C Build an image transformation matrix.
  3619. C
  3620.       DX = (XMAX-XMIN)/NXP
  3621.       DY = (YMAX-YMIN)/NYP
  3622.       RBUF(1) = 0
  3623.       RBUF(2) = NXP
  3624.       RBUF(3) = NYP
  3625.       RBUF(4) = GRXMIN(GRCIDE)
  3626.       RBUF(5) = GRXMAX(GRCIDE)
  3627.       RBUF(6) = GRYMIN(GRCIDE)
  3628.       RBUF(7) = GRYMAX(GRCIDE)
  3629.       RBUF(8) = 1.0/DX
  3630.       RBUF(9) = 0.0
  3631.       RBUF(10) = 0.0
  3632.       RBUF(11) = 1.0/DY
  3633.       RBUF(12) = -XMIN/DX
  3634.       RBUF(13) = -YMIN/DY
  3635. C
  3636. C Send setup info to driver.
  3637. C
  3638.       IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  3639.       CALL GRTERM
  3640.       NBUF = 13
  3641.       LCHR = 0
  3642.       CALL GREXEC(GRGTYP, 26, RBUF, NBUF, CHR, LCHR)
  3643. C
  3644. C Send the array of color indices to the driver.
  3645. C
  3646.       II = 0
  3647.       DO 20 J=J1,J2
  3648.          DO 10 I=I1,I2
  3649.             II = II + 1
  3650.             RBUF(II+1) = IA(I,J)
  3651.             IF (II.EQ.20) THEN
  3652.                NBUF = II+1
  3653.                RBUF(1) = II
  3654.                CALL GREXEC(GRGTYP, 26, RBUF, NBUF, CHR, LCHR)
  3655.                II = 0
  3656.             END IF
  3657.  10      CONTINUE
  3658.  20   CONTINUE
  3659.       IF (II.GT.0) THEN
  3660.          NBUF = II+1
  3661.          RBUF(1) = II
  3662.          CALL GREXEC(GRGTYP, 26, RBUF, NBUF, CHR, LCHR)
  3663.          II = 0
  3664.       END IF
  3665. C
  3666. C Send termination code to driver.
  3667. C
  3668.       NBUF = 1
  3669.       RBUF(1) = -1
  3670.       CALL GREXEC(GRGTYP, 26, RBUF, NBUF, CHR, LCHR)
  3671. C-----------------------------------------------------------------------
  3672.       END
  3673.  
  3674. C*GRPXPX -- Perform pixel operations using pixel primitive
  3675. C+
  3676.       SUBROUTINE GRPXPX (IA, IDIM, JDIM, I1, I2, J1, J2, X, Y)
  3677.       INTEGER IDIM, JDIM, I1, I2, J1, J2
  3678.       INTEGER IA(IDIM,JDIM)
  3679.       REAL    X, Y
  3680. C
  3681. C Arguments:
  3682. C  IA     (input)  : the array to be plotted.
  3683. C  IDIM   (input)  : the first dimension of array A.
  3684. C  JDIM   (input)  : the second dimension of array A.
  3685. C  I1, I2 (input)  : the inclusive range of the first index
  3686. C                    (I) to be plotted.
  3687. C  J1, J2 (input)  : the inclusive range of the second
  3688. C                    index (J) to be plotted.
  3689. C  X, Y   (input)  : the lower left corner of the output region
  3690. C                    (device coordinates)
  3691. C--
  3692. C 16-Jan-1991 - [GvG]
  3693. *  4-Aug-1993 - Debugged by Remko Scharroo
  3694. C-----------------------------------------------------------------------
  3695.       INCLUDE 'f77.GRPCKG1/IN'
  3696.       INTEGER     NSIZE
  3697.       PARAMETER   (NSIZE = 1280)
  3698.       REAL        RBUF(NSIZE + 2)
  3699.       REAL        WIDTH
  3700.       INTEGER     IC1, IC2
  3701.       INTEGER     I, J, L
  3702.       INTEGER     NBUF, LCHR
  3703.       CHARACTER*1 CHR
  3704.  
  3705.       IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  3706. C
  3707. C Get allowable color range and pixel width
  3708. C
  3709.       CALL GRQCOL(IC1, IC2)
  3710.       CALL GREXEC(GRGTYP, 3, RBUF, NBUF, CHR, LCHR)
  3711.       WIDTH = RBUF(3)
  3712.       DO 30 J = J1, J2
  3713. C
  3714. C Compute Y coordinate for this line
  3715. C
  3716.          RBUF(2) = Y + (J - J1) * WIDTH
  3717.          I = I1
  3718.   10        L = 1
  3719. C
  3720. C Compute left X coordinate for this line segment
  3721. C
  3722.             RBUF(1) = X + (I - I1) * WIDTH
  3723. C
  3724. C Check color index
  3725. C
  3726.   20           IF (IA(I, J) .LT. IC1 .OR. IC2 .LT. IA(I, J)) THEN
  3727.                   RBUF(L + 2) = 1
  3728.                ELSE
  3729.                   RBUF(L + 2) = IA(I, J)
  3730.                ENDIF
  3731.                L = L + 1
  3732.                I = I + 1
  3733. C
  3734. C Still room in segment and something left?
  3735. C
  3736.             IF (L .LE. NSIZE .AND. I .LE. I2) GOTO 20
  3737. C
  3738. C Output segment
  3739. C
  3740. *           NBUF = L + 2 ! wrong ! should be: (RS)
  3741.             NBUF = L + 1
  3742.             CALL GREXEC(GRGTYP, 26, RBUF, NBUF, CHR, LCHR)
  3743. C
  3744. C Something left?
  3745. C
  3746.          IF (I .LE. I2) GOTO 10
  3747.   30  CONTINUE
  3748.  
  3749.       END
  3750. C*GRPXRE -- Emulate pixel operations using rectangles
  3751. C+
  3752.       SUBROUTINE GRPXRE (IA, IDIM, JDIM, I1, I2, J1, J2, 
  3753.      1                   X1, X2, Y1, Y2)
  3754.       INTEGER IDIM, JDIM, I1, I2, J1, J2
  3755.       INTEGER IA(IDIM,JDIM)
  3756.       REAL    X1, X2, Y1, Y2
  3757. C
  3758. C Arguments:
  3759. C  IA     (input)  : the array to be plotted.
  3760. C  IDIM   (input)  : the first dimension of array A.
  3761. C  JDIM   (input)  : the second dimension of array A.
  3762. C  I1, I2 (input)  : the inclusive range of the first index
  3763. C                    (I) to be plotted.
  3764. C  J1, J2 (input)  : the inclusive range of the second
  3765. C                    index (J) to be plotted.
  3766. C  X1, X2 (input)  : the horizontal range of the output region
  3767. C  Y1, Y2 (input)  : the vertical range of the output region
  3768. C--
  3769. C 18-Jan-1991 - [GvG]
  3770. C-----------------------------------------------------------------------
  3771.       REAL YB, YT
  3772.       INTEGER I, J, ICOL, LSTCOL
  3773. C
  3774. C Save color attribute
  3775. C
  3776.       CALL GRQCI(ICOL)
  3777.       LSTCOL = ICOL
  3778.       DO 20 J = J1, J2
  3779. C
  3780. C Compute Y range for this index
  3781. C
  3782.          YB = Y1 + ((Y2 - Y1) * (J - J1)) / (J2 - J1 + 1)
  3783.          YT = Y1 + ((Y2 - Y1) * (J - J1 + 1)) / (J2 - J1 + 1)
  3784.          DO 10 I = I1, I2
  3785. C
  3786. C Need to change color?
  3787. C
  3788.             IF (IA(I, J) .NE. LSTCOL) THEN
  3789.                CALL GRSCI(IA(I, J))
  3790.                LSTCOL = IA(I, J)
  3791.             ENDIF
  3792. C
  3793. C Output rectangle
  3794. C
  3795.             CALL GRREC0(X1 + ((X2 - X1) * (I - I1)) / (I2 - I1 + 1), YB,
  3796.      1                  X1 + ((X2 - X1) * (I - I1 + 1)) / (I2 - I1 + 1),
  3797.      2                  YT)
  3798.  
  3799.   10     CONTINUE
  3800.   20  CONTINUE
  3801. C
  3802. C Restore color attribute
  3803. C
  3804.       CALL GRSCI(ICOL)
  3805.       END
  3806. C*GRQCAP -- inquire device capabilities
  3807. C+
  3808.       SUBROUTINE GRQCAP (STRING)
  3809.       CHARACTER*(*) STRING
  3810. C
  3811. C GRPCKG: obtain the "device capabilities" string from the device
  3812. C driver for the current device.
  3813. C
  3814. C Arguments:
  3815. C
  3816. C STRING (output, CHARACTER*(*)): receives the device capabilities
  3817. C       string.
  3818. C--
  3819. C 26-Nov-92: new routine [TJP].
  3820. C  1-Sep-94: get from common instead of driver [TJP].
  3821. C-----------------------------------------------------------------------
  3822.       INCLUDE 'f77.GRPCKG1/IN'
  3823. C
  3824.       IF (GRCIDE.LT.1) THEN
  3825.           CALL GRWARN('GRQCAP - no graphics device is active.')
  3826.           STRING = 'NNNNNNNNNN'
  3827.       ELSE
  3828.           STRING = GRGCAP(GRCIDE)
  3829.       END IF
  3830. C
  3831.       END
  3832. C*GRQCI -- inquire current color index
  3833. C+
  3834.       SUBROUTINE GRQCI (C)
  3835. C
  3836. C GRPCKG: obtain the color index of the current graphics device.
  3837. C
  3838. C Argument:
  3839. C
  3840. C C (integer, output): receives the current color index (0-255).
  3841. C--
  3842. C (1-Feb-1983)
  3843. C-----------------------------------------------------------------------
  3844.       INCLUDE 'f77.GRPCKG1/IN'
  3845.       INTEGER  C
  3846. C
  3847.       IF (GRCIDE.LT.1) THEN
  3848.           CALL GRWARN('GRQCI - no graphics device is active.')
  3849.           C = 1
  3850.       ELSE
  3851.           C = GRCCOL(GRCIDE)
  3852.       END IF
  3853.       END
  3854. C*GRQCOL -- inquire color capability
  3855. C+
  3856.       SUBROUTINE GRQCOL (CI1, CI2)
  3857.       INTEGER  CI1, CI2
  3858. C
  3859. C Query the range of color indices available on the current device.
  3860. C
  3861. C Argument:
  3862. C  CI1    (output) : the minimum available color index. This will be
  3863. C                    either 0 if the device can write in the
  3864. C                    background color, or 1 if not.
  3865. C  CI2    (output) : the maximum available color index. This will be
  3866. C                    1 if the device has no color capability, or a
  3867. C                    larger number (e.g., 3, 7, 15, 255).
  3868. C--
  3869. C 31-May-1989 - new routine [TJP].
  3870. C  1-Sep-1994 - avoid driver call [TJP].
  3871. C-----------------------------------------------------------------------
  3872.       INCLUDE 'f77.GRPCKG1/IN'
  3873. C
  3874. C Error if no workstation is open.
  3875. C
  3876.       IF (GRCIDE.LT.1) THEN
  3877.           CI1 = 0
  3878.           CI2 = 0
  3879.       ELSE
  3880.           CI1 = GRMNCI(GRCIDE)
  3881.           CI2 = GRMXCI(GRCIDE)
  3882.       END IF
  3883. C
  3884.       END
  3885. C*GRQCR -- inquire color representation
  3886. C+
  3887.       SUBROUTINE GRQCR (CI, CR, CG, CB)
  3888.       INTEGER  CI
  3889.       REAL     CR, CG, CB
  3890. C
  3891. C Return the color representation (red, green, blue intensities) 
  3892. C currently associated with the specified color index. This may be
  3893. C different from that requested on some devices.
  3894. C
  3895. C Arguments:
  3896. C
  3897. C CI (integer, input): color index.
  3898. C CR, CG, CB (real, output): red, green, and blue intensities,
  3899. C       in range 0.0 to 1.0.
  3900. C--
  3901. C  7-Sep-1994 - rewrite [TJP].
  3902. C-----------------------------------------------------------------------
  3903.       INCLUDE 'f77.GRPCKG1/IN'
  3904.       INTEGER   NBUF, LCHR, K
  3905.       REAL      RBUF(6)
  3906.       CHARACTER CHR
  3907. C
  3908.       CR = 1.0
  3909.       CG = 1.0
  3910.       CB = 1.0
  3911.       K  = CI
  3912.       IF (GRCIDE.LT.1) THEN
  3913. C         -- no device open: return white
  3914.           CALL GRWARN('GRQCR: no plot device is open.')
  3915.       ELSE IF (GRGCAP(GRCIDE)(9:9).NE.'Y') THEN
  3916. C         -- devices that don't allow query color representation:
  3917. C            return black for ci 0, white for all others
  3918.           IF (K.EQ.0) THEN
  3919.              CR = 0.0
  3920.              CG = 0.0
  3921.              CB = 0.0
  3922.           END IF
  3923.       ELSE
  3924. C         -- query device driver; treat invalid ci as 1
  3925.           IF (K.LT.GRMNCI(GRCIDE) .OR. CI.GT.GRMXCI(GRCIDE)) THEN
  3926.              CALL GRWARN('GRQCR: invalid color index.')
  3927.              K = 1
  3928.           END IF
  3929.           RBUF(1) = K
  3930.           NBUF = 1
  3931.           LCHR = 0
  3932.           CALL GREXEC(GRGTYP,29,RBUF,NBUF,CHR,LCHR)
  3933.           IF (NBUF.LT.4) THEN
  3934.              CALL GRWARN('GRSCR: device driver error')
  3935.           ELSE
  3936.               CR = RBUF(2)
  3937.               CG = RBUF(3)
  3938.               CB = RBUF(4)
  3939.           END IF
  3940.       END IF
  3941. C
  3942.       END
  3943.  
  3944. C*GRQDEV -- inquire current device
  3945. C+
  3946.       SUBROUTINE GRQDEV (DEVICE, L)
  3947.       CHARACTER*(*) DEVICE
  3948.       INTEGER L
  3949. C
  3950. C Obtain the name of the current graphics device or file.
  3951. C
  3952. C Argument:
  3953. C  DEVICE (output): receives the device name of the
  3954. C       currently active device.
  3955. C  L (output): number of characters in DEVICE, excluding trailing
  3956. C       blanks.
  3957. C--
  3958. C 19-Feb-1988
  3959. C-----------------------------------------------------------------------
  3960.       INCLUDE 'f77.GRPCKG1/IN'
  3961. C
  3962.       IF (GRCIDE.LT.1) THEN
  3963.           DEVICE = '?'
  3964.           L = 1
  3965.       ELSE
  3966.           DEVICE = GRFILE(GRCIDE)
  3967.           L = GRFNLN(GRCIDE)
  3968.           IF (L.GT.LEN(DEVICE)) L = LEN(DEVICE)
  3969.       END IF
  3970.       END
  3971.  
  3972. C*GRQDT -- inquire current device and type
  3973. C+
  3974.       SUBROUTINE GRQDT (DEVICE)
  3975. C
  3976. C GRPCKG: obtain the name and type of the current graphics device.
  3977. C
  3978. C Argument:
  3979. C
  3980. C DEVICE (output, character): receives the device name and type of the
  3981. C       currently active device in the form 'device/type'; this is a
  3982. C       valid string for input to GROPEN.
  3983. C--
  3984. C  1-Feb-1983
  3985. C 19-Feb-1988 - add quotes if necessary.
  3986. C-----------------------------------------------------------------------
  3987.       INCLUDE 'f77.GRPCKG1/IN'
  3988.       CHARACTER*(*) DEVICE
  3989.       CHARACTER*14 TYPE
  3990.       LOGICAL   JUNK
  3991.       INTEGER   L
  3992. C
  3993.       IF (GRCIDE.LT.1) THEN
  3994.           CALL GRWARN('GRQDT - no graphics device is active.')
  3995.           DEVICE = '/NULL'
  3996.       ELSE
  3997.           CALL GRQTYP(TYPE,JUNK)
  3998.           L = GRFNLN(GRCIDE)
  3999.           IF (L.LE.0) THEN
  4000.               DEVICE = '/'//TYPE
  4001.           ELSE IF (INDEX(GRFILE(GRCIDE)(1:L), '/').EQ.0) THEN
  4002.               DEVICE = GRFILE(GRCIDE)(1:L)//'/'//TYPE
  4003.           ELSE
  4004.               DEVICE = '"'//GRFILE(GRCIDE)(1:L)//'"/'//TYPE
  4005.           END IF
  4006.       END IF
  4007.       END
  4008. C*GRQFNT -- inquire current font
  4009. C+
  4010.       SUBROUTINE GRQFNT (IF)
  4011. C
  4012. C GRPCKG: obtain the font number of the current graphics device.
  4013. C
  4014. C Argument:
  4015. C
  4016. C IF (integer, output): receives the current font number (1-3).
  4017. C--
  4018. C (19-Mar-1983)
  4019. C 15-Dec-1988 - change name [TJP].
  4020. C-----------------------------------------------------------------------
  4021.       INCLUDE 'f77.GRPCKG1/IN'
  4022.       INTEGER  IF
  4023. C
  4024.       IF (GRCIDE.LT.1) THEN
  4025.           CALL GRWARN('GRQFNT - no graphics device is active.')
  4026.           IF = 1
  4027.       ELSE
  4028.           IF = GRCFNT(GRCIDE)
  4029.       END IF
  4030.       END
  4031.  
  4032. C*GRQLS -- inquire current line-style
  4033. C+
  4034.       SUBROUTINE GRQLS (ISTYLE)
  4035.       INTEGER  ISTYLE
  4036. C
  4037. C GRPCKG: obtain the line-style of the current graphics device.
  4038. C
  4039. C Argument:
  4040. C  ISTYLE (output): receives the current line-style code.
  4041. C--
  4042. C (1-Feb-1983)
  4043. C-----------------------------------------------------------------------
  4044.       INCLUDE 'f77.GRPCKG1/IN'
  4045. C
  4046.       IF (GRCIDE.LT.1) THEN
  4047.           CALL GRWARN('GRQLS - no graphics device is active.')
  4048.           ISTYLE = 1
  4049.       ELSE
  4050.           ISTYLE = GRSTYL(GRCIDE)
  4051.       END IF
  4052.       END
  4053. C*GRQLW -- inquire current line width
  4054. C+
  4055.       SUBROUTINE GRQLW (IWIDTH)
  4056.       INTEGER  IWIDTH
  4057. C
  4058. C GRPCKG: obtain the line-width of the current graphics device.
  4059. C
  4060. C Argument:
  4061. C  IWIDTH (output): receives the current line-width.
  4062. C--
  4063. C (1-Feb-1983)
  4064. C-----------------------------------------------------------------------
  4065.       INCLUDE 'f77.GRPCKG1/IN'
  4066. C
  4067.       IF (GRCIDE.LT.1) THEN
  4068.           CALL GRWARN('GRQLW - no graphics device is active.')
  4069.           IWIDTH = 1
  4070.       ELSE
  4071.           IWIDTH = ABS(GRWIDT(GRCIDE))
  4072.       END IF
  4073.       END
  4074. C*GRQPOS -- return current pen position (absolute, world coordinates)
  4075. C+
  4076.       SUBROUTINE GRQPOS(X,Y)
  4077. C
  4078. C GRQPOS: returns the current pen position in absolute, world
  4079. C coordinates.
  4080. C
  4081. C Arguments:
  4082. C
  4083. C X, Y (real, output): world coordinates of the pen position.
  4084. C--
  4085. C  1-Mar-1991 - new routine  [JM].
  4086. C-----------------------------------------------------------------------
  4087.       REAL     X,Y
  4088.       INCLUDE 'f77.GRPCKG1/IN'
  4089. C
  4090.       IF (GRCIDE.GE.1) THEN
  4091.           X = (GRXPRE(GRCIDE) - GRXORG(GRCIDE)) / GRXSCL(GRCIDE)
  4092.           Y = (GRYPRE(GRCIDE) - GRYORG(GRCIDE)) / GRYSCL(GRCIDE)
  4093.       END IF
  4094.       END
  4095. C*GRQTXT -- get text bounding box
  4096. C+
  4097.       SUBROUTINE GRQTXT (ORIENT,X0,Y0,STRING, XBOX, YBOX)
  4098. C
  4099. C GRPCKG: get the bounding box of a string drawn by GRTEXT.
  4100. C--
  4101. C 12-Sep-1993 - [TJP].
  4102. C  8-Nov-1994 - return something even if string is blank [TJP].
  4103. C-----------------------------------------------------------------------
  4104.       INCLUDE 'f77.GRPCKG1/IN'
  4105.       LOGICAL UNUSED, VISBLE, PLOT
  4106.       INTEGER XYGRID(300)
  4107.       INTEGER LIST(256)
  4108.       CHARACTER*(*) STRING
  4109.       REAL XBOX(4), YBOX(4)
  4110.       REAL ANGLE, FACTOR, FNTBAS, FNTFAC, COSA, SINA, DX, DY, XORG, YORG
  4111.       REAL ORIENT, RATIO, X0, Y0, RLX, RLY
  4112.       REAL XG, YG, XGMIN, XGMAX, YGMIN, YGMAX
  4113.       INTEGER I, IFNTLV,NLIST,LX,LY, K, LXLAST,LYLAST
  4114.       INTRINSIC ABS, COS, LEN, MAX, MIN, SIN
  4115. C
  4116. C Default return values.
  4117. C
  4118.       DO 10 I=1,4
  4119.          XBOX(I) = X0
  4120.          YBOX(I) = Y0
  4121.  10   CONTINUE
  4122. C
  4123. C Check that there is something to be plotted.
  4124. C
  4125.       IF (LEN(STRING).LE.0) RETURN
  4126. C
  4127. C Check that a device is selected.
  4128. C
  4129.       IF (GRCIDE.LT.1) THEN
  4130.           CALL GRWARN('GRQTXT - no graphics device is active.')
  4131.           RETURN
  4132.       END IF
  4133. C
  4134.       XORG = GRXPRE(GRCIDE)
  4135.       YORG = GRYPRE(GRCIDE)
  4136. C
  4137. C Compute scaling and orientation.
  4138. C
  4139.       ANGLE = ORIENT*(3.14159265/180.)
  4140.       FACTOR = GRCFAC(GRCIDE)/2.5
  4141.       RATIO = GRPXPI(GRCIDE)/GRPYPI(GRCIDE)
  4142.       COSA = FACTOR * COS(ANGLE)
  4143.       SINA = FACTOR * SIN(ANGLE)
  4144.       XORG = X0
  4145.       YORG = Y0
  4146. C
  4147. C Convert the string to a list of symbol numbers; to prevent overflow
  4148. C of array LIST, the length of STRING is limited to 256 characters.
  4149. C
  4150.       CALL GRSYDS(LIST,NLIST,STRING(1:MIN(256,LEN(STRING))),
  4151.      1             GRCFNT(GRCIDE))
  4152. C
  4153. C Run through the string of characters, getting bounding box
  4154. C in character coordinates. (XG, YG) is the starting point
  4155. C of the current character. The x/y limits of the bbox are
  4156. C XGMIN...XGMAX, YGMIN...YGMAX.
  4157. C
  4158.       FNTBAS = 0.0
  4159.       FNTFAC = 1.0
  4160.       IFNTLV = 0
  4161.       DX = 0.0
  4162.       DY = 0.0
  4163.       XG = 0.0
  4164.       YG = 0.0
  4165.       XGMIN = 1E30
  4166.       XGMAX = -1E30
  4167.       YGMIN = 1E30
  4168.       YGMAX = -1E30
  4169.       PLOT  = .FALSE.
  4170.       DO 380 I=1,NLIST
  4171.           IF (LIST(I).LT.0) THEN
  4172.               IF (LIST(I).EQ.-1) THEN
  4173. C                 ! up
  4174.                   IFNTLV = IFNTLV+1
  4175.                   FNTBAS = FNTBAS + 16.0*FNTFAC
  4176.                   FNTFAC = 0.75**ABS(IFNTLV)
  4177.               ELSE IF (LIST(I).EQ.-2) THEN
  4178. C                 ! down
  4179.                   IFNTLV = IFNTLV-1
  4180.                   FNTFAC = 0.75**ABS(IFNTLV)
  4181.                   FNTBAS = FNTBAS - 16.0*FNTFAC
  4182.               ELSE IF (LIST(I).EQ.-3) THEN
  4183. C                 ! backspace
  4184.                   XG = XG - DX*FNTFAC
  4185.               END IF
  4186.               GOTO 380
  4187.           END IF
  4188.           CALL GRSYXD(LIST(I),XYGRID,UNUSED)
  4189.           VISBLE = .FALSE.
  4190.           DX = XYGRID(5)-XYGRID(4)
  4191.           K = 4
  4192.           LXLAST = -64
  4193.           LYLAST = -64
  4194.   320     K = K+2
  4195.           LX = XYGRID(K)
  4196.           LY = XYGRID(K+1)
  4197.           IF (LY.EQ.-64) GOTO 330
  4198.           IF (LX.EQ.-64) THEN
  4199.               VISBLE = .FALSE.
  4200.           ELSE
  4201.               RLX = (LX - XYGRID(4))*FNTFAC
  4202.               RLY = (LY - XYGRID(2))*FNTFAC + FNTBAS
  4203.               IF ((LX.NE.LXLAST) .OR. (LY.NE.LYLAST)) THEN
  4204.                   XGMIN = MIN(XGMIN,XG+RLX)
  4205.                   XGMAX = MAX(XGMAX,XG+RLX)
  4206.                   YGMIN = MIN(YGMIN,RLY)
  4207.                   YGMAX = MAX(YGMAX,RLY)
  4208.                   PLOT = .TRUE.
  4209.               END IF
  4210.               VISBLE = .TRUE.
  4211.               LXLAST = LX
  4212.               LYLAST = LY
  4213.           END IF
  4214.           GOTO 320
  4215.   330     XG = XG + DX*FNTFAC
  4216.   380 CONTINUE
  4217. C
  4218. C Check whether anything was plotted.
  4219. C
  4220.       IF (.NOT.PLOT) RETURN
  4221. C
  4222. C Expand the box a bit to allow for line-width.
  4223. C
  4224.       XGMIN = XGMIN - 5.0
  4225.       XGMAX = XGMAX + 5.0
  4226.       YGMIN = YGMIN - 4.0
  4227.       YGMAX = YGMAX + 4.0
  4228. C
  4229. C Convert bounding box to device coordinates.
  4230. C
  4231. C     WRITE (*,*) XGMIN, XGMAX, YGMIN, YGMAX
  4232.       XBOX(1) = XORG + (COSA*XGMIN - SINA*YGMIN)*RATIO
  4233.       YBOX(1) = YORG + (SINA*XGMIN + COSA*YGMIN)
  4234.       XBOX(2) = XORG + (COSA*XGMIN - SINA*YGMAX)*RATIO
  4235.       YBOX(2) = YORG + (SINA*XGMIN + COSA*YGMAX)
  4236.       XBOX(3) = XORG + (COSA*XGMAX - SINA*YGMAX)*RATIO
  4237.       YBOX(3) = YORG + (SINA*XGMAX + COSA*YGMAX)
  4238.       XBOX(4) = XORG + (COSA*XGMAX - SINA*YGMIN)*RATIO
  4239.       YBOX(4) = YORG + (SINA*XGMAX + COSA*YGMIN)
  4240. C
  4241.       END
  4242. C*GRQTYP -- inquire current device type
  4243. C+
  4244.       SUBROUTINE GRQTYP (TYPE,INTER)
  4245.       CHARACTER*(*) TYPE
  4246.       LOGICAL INTER
  4247. C
  4248. C GRPCKG: obtain the device type of the currently selected graphics
  4249. C device, and determine whether or not it is an interactive device.
  4250. C
  4251. C Arguments:
  4252. C
  4253. C TYPE (output, CHARACTER*(*)): receives the device type, as a
  4254. C       character string, eg 'PRINTRONIX', 'TRILOG', 'VERSATEC',
  4255. C       'TEK4010', 'TEK4014', 'GRINNELL', or 'VT125'.  The character
  4256. C       string should have a length of at least 8 to ensure that the
  4257. C       type is unique.
  4258. C INTER (output, LOGICAL): receives the value .TRUE. if the device is
  4259. C       interactive, .FALSE. otherwise.
  4260. C--
  4261. C (23-May-1983)
  4262. C  5-Aug-1986 - add GREXEC support [AFT].
  4263. C 18-Jan-1993 - return type only, not description [TJP].
  4264. C  1-Sep-1994 - get capabilities from common [TJP].
  4265. C-----------------------------------------------------------------------
  4266.       INCLUDE 'f77.GRPCKG1/IN'
  4267.       REAL    RBUF(6)
  4268.       INTEGER NBUF,LCHR
  4269.       CHARACTER*32 CHR
  4270. C
  4271.       IF (GRCIDE.LT.1) THEN
  4272.           CALL GRWARN('GRQTYP - no graphics device is active.')
  4273.           TYPE = 'NULL'
  4274.           INTER = .FALSE.
  4275.       ELSE
  4276.           CALL GREXEC(GRGTYP, 1,RBUF,NBUF,CHR,LCHR)
  4277.           LCHR = INDEX(CHR,' ')
  4278.           TYPE = CHR(:LCHR)
  4279.           INTER = (GRGCAP(GRCIDE)(1:1).EQ.'I')
  4280.       END IF
  4281. C
  4282.       END
  4283. C*GRQUIT -- report a fatal error and abort execution
  4284. C+
  4285.       SUBROUTINE GRQUIT (TEXT)
  4286.       CHARACTER*(*) TEXT
  4287. C
  4288. C Report a fatal error (via GRWARN) and exit program.
  4289. C This routine should be called in the event of an unrecoverable 
  4290. C PGPLOT error.
  4291. C
  4292. C Argument:
  4293. C  TEXT (input): text of message to be sent to GRWARN.
  4294. C--
  4295. C 12-Nov-1994
  4296. C-----------------------------------------------------------------------
  4297. C
  4298.       CALL GRWARN(TEXT)
  4299.       CALL GRWARN('Fatal error in PGPLOT library: program terminating.')
  4300.       STOP 
  4301.       END
  4302. C*GRREC0 -- fill a rectangle (device coordinates)
  4303. C+
  4304.       SUBROUTINE GRREC0 (X0,Y0,X1,Y1)
  4305.       REAL X0, Y0, X1, Y1
  4306. C
  4307. C GRPCKG: Fill a rectangle with solid color.  The rectangle
  4308. C is defined by the (x,y) device coordinates of its lower left and
  4309. C upper right corners; the edges are parallel to the coordinate axes.
  4310. C X0 is guaranteed to be <= X1 and Y0 <= Y1. The rectangle possible
  4311. C extends beyond the clipping boundaries
  4312. C
  4313. C Arguments:
  4314. C
  4315. C X0, Y0 (input, real): device coordinates of one corner of the 
  4316. C       rectangle.
  4317. C X1, Y1 (input, real): device coordinates of the opposite corner of 
  4318. C       the rectangle.
  4319. C--
  4320. C 23-Mar-1988 - [TJP].
  4321. C 18-Jan-1991 - Code moved from GRRECT to GRREC0 so that it can also be
  4322. C               used by GRPXRE.
  4323. C  1-Sep-1994 - suppress driver call [TJP].
  4324. C  4-Dec-1995 - avoid use of real variable as do-loop index [TJP].
  4325. C-----------------------------------------------------------------------
  4326.       INCLUDE 'f77.GRPCKG1/IN'
  4327.       REAL    RBUF(6)
  4328.       INTEGER NBUF,LCHR
  4329.       CHARACTER*32 CHR
  4330.       REAL    XMIN, YMIN, XMAX, YMAX, Y, DY
  4331.       INTEGER LS, LW, I, NLINES
  4332. C
  4333. C Clip
  4334. C
  4335.       XMIN = X0
  4336.       XMAX = X1
  4337.       YMIN = Y0
  4338.       YMAX = Y1
  4339.       IF (XMIN .LT. GRXMIN(GRCIDE)) XMIN = GRXMIN(GRCIDE)
  4340.       IF (XMAX .GT. GRXMAX(GRCIDE)) XMAX = GRXMAX(GRCIDE)
  4341.       IF (YMIN .LT. GRYMIN(GRCIDE)) YMIN = GRYMIN(GRCIDE)
  4342.       IF (YMAX .GT. GRYMAX(GRCIDE)) YMAX = GRYMAX(GRCIDE)
  4343.       IF (XMIN .GT. XMAX) RETURN
  4344.       IF (YMIN .GT. YMAX) RETURN
  4345. C
  4346. C Use hardware rectangle fill if available.
  4347. C
  4348.       IF (GRGCAP(GRCIDE)(6:6).EQ.'R') THEN
  4349.           IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  4350.           RBUF(1) = XMIN
  4351.           RBUF(2) = YMIN
  4352.           RBUF(3) = XMAX
  4353.           RBUF(4) = YMAX
  4354.           CALL GREXEC(GRGTYP,24,RBUF,NBUF,CHR,LCHR)
  4355.           RETURN
  4356. C
  4357. C Else use hardware polygon fill if available.
  4358. C
  4359.       ELSE IF (GRGCAP(GRCIDE)(4:4).EQ.'A') THEN
  4360.           IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  4361.           RBUF(1) = 4
  4362.           CALL GREXEC(GRGTYP,20,RBUF,NBUF,CHR,LCHR)
  4363.           RBUF(1) = XMIN
  4364.           RBUF(2) = YMIN
  4365.           CALL GREXEC(GRGTYP,20,RBUF,NBUF,CHR,LCHR)
  4366.           RBUF(1) = XMAX
  4367.           RBUF(2) = YMIN
  4368.           CALL GREXEC(GRGTYP,20,RBUF,NBUF,CHR,LCHR)
  4369.           RBUF(1) = XMAX
  4370.           RBUF(2) = YMAX
  4371.           CALL GREXEC(GRGTYP,20,RBUF,NBUF,CHR,LCHR)
  4372.           RBUF(1) = XMIN
  4373.           RBUF(2) = YMAX
  4374.           CALL GREXEC(GRGTYP,20,RBUF,NBUF,CHR,LCHR)
  4375.           RETURN
  4376.       END IF
  4377. C
  4378. C For other devices fill area is simulated.
  4379. C
  4380. C Save attributes.
  4381. C
  4382.       CALL GRQLS(LS)
  4383.       CALL GRQLW(LW)
  4384.       CALL GRSLS(1)
  4385.       CALL GRSLW(1)
  4386.       CALL GREXEC(GRGTYP, 3,RBUF,NBUF,CHR,LCHR)
  4387.       DY = RBUF(3)
  4388. C
  4389. C Draw horizontal raster lines.
  4390. C
  4391.       NLINES = ABS((YMAX-YMIN)/DY)
  4392.       Y = YMIN - DY/2.0
  4393.       DO 40 I=1,NLINES
  4394.          Y = Y + DY
  4395.          GRXPRE(GRCIDE) = XMIN
  4396.          GRYPRE(GRCIDE) = Y
  4397.          CALL GRLIN0(XMAX,Y)
  4398.    40 CONTINUE
  4399. C
  4400. C Restore attributes.
  4401. C
  4402.       CALL GRSLS(LS)
  4403.       CALL GRSLW(LW)
  4404.       END
  4405.  
  4406. C*GRRECT -- fill a rectangle
  4407. C+
  4408.       SUBROUTINE GRRECT (X0,Y0,X1,Y1)
  4409.       REAL X0, Y0, X1, Y1
  4410. C
  4411. C GRPCKG: Fill a rectangle with solid color.  The rectangle
  4412. C is defined by the (x,y) world coordinates of its lower left and upper 
  4413. C right corners; the edges are parallel to the coordinate axes.
  4414. C
  4415. C Arguments:
  4416. C
  4417. C X0, Y0 (input, real): world coordinates of one corner of the 
  4418. C       rectangle.
  4419. C X1, Y1 (input, real): world coordinates of the opposite corner of the 
  4420. C       rectangle.
  4421. C--
  4422. C 23-Mar-1988 - [TJP].
  4423. C 18-Jan-1991 - Code moved from GRRECT to GRREC0 so that it can also be
  4424. C               used by GRPXRE
  4425. C-----------------------------------------------------------------------
  4426.       INCLUDE 'f77.GRPCKG1/IN'
  4427.       REAL    XLL, YLL, XUR, YUR
  4428.       REAL    XMIN, YMIN, XMAX, YMAX
  4429. C
  4430.       IF (GRCIDE.LT.1) RETURN
  4431. C
  4432. C Convert to device coordinates and clip.
  4433. C
  4434.       CALL GRTXY0(.FALSE.,X0,Y0,XLL,YLL)
  4435.       CALL GRTXY0(.FALSE.,X1,Y1,XUR,YUR)
  4436.       XMIN = MIN(XLL,XUR)
  4437.       XMAX = MAX(XLL,XUR)
  4438.       YMIN = MIN(YLL,YUR)
  4439.       YMAX = MAX(YLL,YUR)
  4440. C
  4441. C Do the real work
  4442. C
  4443.       CALL GRREC0(XMIN,YMIN,XMAX,YMAX)
  4444.       END
  4445. C*GRSCI -- set color index
  4446. C+
  4447.       SUBROUTINE GRSCI (IC)
  4448. C
  4449. C GRPCKG: Set the color index for subsequent plotting. Calls to GRSCI
  4450. C are ignored for monochrome devices. The default color index is 1,
  4451. C usually white on a black background for video displays or black on a
  4452. C white background for printer plots. The color index is an integer in
  4453. C the range 0 to a device-dependent maximum. Color index 0 corresponds
  4454. C to the background color; lines may be "erased" by overwriting them
  4455. C with color index 0.
  4456. C
  4457. C Color indices 0-7 are predefined as follows: 0 = black (background
  4458. C color), 1 = white (default), 2 = red, 3 = green, 4 = blue, 5 = cyan
  4459. C (blue + green), 6 = magenta (red + blue), 7 = yellow (red + green).
  4460. C The assignment of colors to color indices can be changed with
  4461. C subroutine GRSCR (set color representation).
  4462. C
  4463. C Argument:
  4464. C
  4465. C IC (integer, input): the color index to be used for subsequent
  4466. C       plotting on the current device (in range 0-255). If the
  4467. C       index exceeds the device-dependent maximum, the result is
  4468. C       device-dependent.
  4469. C--
  4470. C 11-Apr-1983 - [TJP].
  4471. C  3-Jun-1984 - add GMFILE device [TJP].
  4472. C 13-Jun-1984 - add code for TK4100 devices [TJP].
  4473. C  2-Jul-1984 - add code for RETRO and VT125 (REGIS) devices [TJP].
  4474. C  2-Oct-1984 - change REGIS to improve VT240 behavior [TJP].
  4475. C 22-Dec-1984 - add PRTX, TRILOG, VERS and VV devices [TJP].
  4476. C 29-Jan-1985 - add HP2648 device [KS/TJP].
  4477. C  5-Aug-1986 - add GREXEC support [AFT].
  4478. C 21-Feb-1987 - delays setting color if picture not open [AFT].
  4479. C 11-Jun-1987 - remove built-in devices [TJP].
  4480. C 31-May-1989 - add check for valid color index [TJP].
  4481. C  1-Sep-1994 - use common data [TJP].
  4482. C-----------------------------------------------------------------------
  4483.       INCLUDE 'f77.GRPCKG1/IN'
  4484.       INTEGER  IC, COLOR, IC1, IC2, NBUF,LCHR
  4485.       REAL     RBUF(6)
  4486.       CHARACTER*1 CHR
  4487. C
  4488. C Error if no workstation is open.
  4489. C
  4490.       IF (GRCIDE.LT.1) THEN
  4491.           CALL GRWARN('GRSCI - no graphics device is active.')
  4492.           RETURN
  4493.       END IF
  4494. C
  4495. C Use color index 1 if out of range.
  4496. C
  4497.       IC1 = GRMNCI(GRCIDE)
  4498.       IC2 = GRMXCI(GRCIDE)
  4499.       COLOR = IC
  4500.       IF (COLOR.LT.IC1 .OR. COLOR.GT.IC2) COLOR = 1
  4501. C
  4502. C If no change to color index is requested, take no action.
  4503. C
  4504.       IF (COLOR.EQ.GRCCOL(GRCIDE)) RETURN
  4505. C
  4506. C If the workstation is in "picture open" state, send command to
  4507. C driver.
  4508. C
  4509.       IF (GRPLTD(GRCIDE)) THEN
  4510.           RBUF(1) = COLOR
  4511.           CALL GREXEC(GRGTYP,15,RBUF,NBUF,CHR,LCHR)
  4512.       END IF
  4513. C
  4514. C Set the current color index.
  4515. C
  4516.       GRCCOL(GRCIDE)=COLOR
  4517. C
  4518.       END
  4519. C*GRSCR -- set color representation
  4520. C+
  4521.       SUBROUTINE GRSCR (CI, CR, CG, CB)
  4522.       INTEGER  CI
  4523.       REAL     CR, CG, CB
  4524. C
  4525. C GRPCKG: SET COLOUR REPRESENTATION -- define the colour to be
  4526. C associated with a colour index.  Ignored for devices which do not
  4527. C support variable colour or intensity.  On monochrome output
  4528. C devices (e.g. VT125 terminals with monochrome monitors), the
  4529. C monochrome intensity is computed from the specified Red, Green, Blue
  4530. C intensities as 0.30*R + 0.59*G + 0.11*B, as in US color television
  4531. C systems, NTSC encoding.  Note that most devices do not have an
  4532. C infinite range of colours or monochrome intensities available;
  4533. C the nearest available colour is used.
  4534. C
  4535. C Arguments:
  4536. C
  4537. C CI (integer, input): colour index. If the colour index is outside the
  4538. C       range available on the device, the call is ignored. Colour
  4539. C       index 0 applies to the background colour.
  4540. C CR, CG, CB (real, input): red, green, and blue intensities,
  4541. C       in range 0.0 to 1.0.
  4542. C--
  4543. C 20-Feb-1984 - [TJP].
  4544. C  5-Jun-1984 - add GMFILE device [TJP].
  4545. C  2-Jul-1984 - add REGIS device [TJP].
  4546. C  2-Oct-1984 - change use of map tables in Regis [TJP].
  4547. C 11-Nov-1984 - add code for /TK [TJP].
  4548. C  1-Sep-1986 - add GREXEC support [AFT].
  4549. C 21-Feb-1987 - If needed, calls begin picture [AFT].
  4550. C 31-Aug-1994 - suppress call of begin picture [TJP].
  4551. C  1-Sep-1994 - use common data [TJP].
  4552. C 26-Jul-1995 - fix bug: some drivers would ignore a change to the
  4553. C               current color [TJP].
  4554. C-----------------------------------------------------------------------
  4555.       INCLUDE 'f77.GRPCKG1/IN'
  4556.       INTEGER   NBUF, LCHR
  4557.       REAL      RBUF(6)
  4558.       CHARACTER CHR
  4559. C
  4560.       IF (GRCIDE.LT.1) THEN
  4561.           CALL GRWARN('GRSCR - Specified workstation is not open.')
  4562.       ELSE IF (CR.LT.0.0 .OR. CG.LT.0.0 .OR. CB.LT.0.0 .OR.
  4563.      1    CR.GT.1.0 .OR. CG.GT.1.0 .OR. CB.GT.1.0) THEN
  4564.           CALL GRWARN('GRSCR - Colour is outside range [0,1].')
  4565.       ELSE IF (CI.GE.GRMNCI(GRCIDE) .AND. CI.LE.GRMXCI(GRCIDE)) THEN
  4566. C         IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  4567.           RBUF(1)=CI
  4568.           RBUF(2)=CR
  4569.           RBUF(3)=CG
  4570.           RBUF(4)=CB
  4571.           NBUF=4
  4572.           CALL GREXEC(GRGTYP,21,RBUF,NBUF,CHR,LCHR)
  4573. C         -- If this is the current color, reselect it in the driver.
  4574.           IF (CI.EQ.GRCCOL(GRCIDE)) THEN
  4575.              RBUF(1) = CI
  4576.              CALL GREXEC(GRGTYP,15,RBUF,NBUF,CHR,LCHR)
  4577.           END IF
  4578.       END IF
  4579. C
  4580.       END
  4581.  
  4582. C*GRSETC -- set character size
  4583. C+
  4584.       SUBROUTINE GRSETC (IDENT,XSIZE)
  4585. C
  4586. C GRPCKG : change the character size (user-callable routine).
  4587. C
  4588. C Input:   IDENT : plot identifier
  4589. C          XSIZE : the new character width. The character height
  4590. C                  and spacing will be scaled by the same factor.
  4591. C                  If XSIZE is negative or zero, the character size
  4592. C                  will be set to the default size.
  4593. C--
  4594. C (1-Feb-1983)
  4595. C 16-Sep-1985 - add code for metafile output (TJP).
  4596. C-----------------------------------------------------------------------
  4597.       INCLUDE 'f77.GRPCKG1/IN'
  4598.       INTEGER IDENT
  4599.       REAL XSIZE
  4600. C
  4601. C Record the new size (GRCFAC).
  4602. C
  4603.       CALL GRSLCT(IDENT)
  4604.       IF (XSIZE.LE.0.0) THEN
  4605.           GRCFAC(IDENT) = 1.0
  4606.       ELSE
  4607.           GRCFAC(IDENT) = XSIZE / GRCXSZ
  4608.       END IF
  4609. C
  4610.       END
  4611. C*GRSETFONT -- set text font [obsolete]
  4612. C
  4613.       SUBROUTINE GRSETFONT (IF)
  4614.       INTEGER IF
  4615.       CALL GRSFNT(IF)
  4616.       END
  4617. C*GRSETLI -- *obsolete routine*
  4618. C+
  4619.       SUBROUTINE GRSETLI (IN)
  4620. C
  4621. C GRPCKG: Set the line intensity for subsequent plotting on the current
  4622. C device. *** OBSOLETE ROUTINE *** Intensity is now set with GRSCI
  4623. C and GRSCR. For compatibility, GRSETLI now sets color zero if its
  4624. C argument is 0, and resets the previous color if its argument is
  4625. C non-zero.
  4626. C
  4627. C Argument:
  4628. C
  4629. C IN (integer, input): the intensity to be used for subsequent
  4630. C       plotting on the current device (in range 0-3).
  4631. C--
  4632. C 11-Apr-1983 - [TJP].
  4633. C 12-Jul-1984 - modify to call GRSCI [TJP].
  4634. C-----------------------------------------------------------------------
  4635.       INCLUDE 'f77.GRPCKG1/IN'
  4636.       INTEGER  IN, OLDCOL(GRIMAX)
  4637.       DATA     OLDCOL /GRIMAX*1/
  4638. C
  4639.       IF (GRCIDE.LT.1) THEN
  4640.           CALL GRWARN('GRSETLI - no graphics device is active.')
  4641.       ELSE IF (IN.EQ.0) THEN
  4642.           OLDCOL(GRCIDE) = GRCCOL(GRCIDE)
  4643.           CALL GRSCI(0)
  4644.       ELSE
  4645.           CALL GRSCI(OLDCOL(GRCIDE))
  4646.       END IF
  4647.       END
  4648.  
  4649. C*GRSETPEN -- *obsolete routine*
  4650. C+
  4651.       SUBROUTINE GRSETPEN
  4652. C
  4653. C GRPCKG: Set the pen number for subsequent plotting.  Obsolete
  4654. C routine: ignored.
  4655. C-----------------------------------------------------------------------
  4656.       CALL GRWARN('GRSETPEN is an obsolete routine.')
  4657.       END
  4658. C*GRSETS -- change size of view surface
  4659. C+
  4660.       SUBROUTINE GRSETS (IDENT,XSIZE,YSIZE)
  4661. C
  4662. C GRPCKG : change size of plotting area. The requested dimensions
  4663. C will be reduced to the absolute maximum of the plot device if
  4664. C necessary.
  4665. C
  4666. C Arguments:
  4667. C
  4668. C IDENT (input, integer): plot identifier from GROPEN.
  4669. C XSIZE (input, real): new x dimension of plot area (absolute
  4670. C               units); if less than zero, the default dimension
  4671. C               will be used.
  4672. C YSIZE (input, real): new y dimension of plot area (absolute
  4673. C               units); if less than zero, the default dimension
  4674. C               will be used.
  4675. C--
  4676. C (1-Feb-1983)
  4677. C  5-Aug-1986 - add GREXEC support [AFT].
  4678. C  5-Jan-1993 - set GRADJU [TJP].
  4679. C------------------------------------------------------------------------
  4680.       INCLUDE 'f77.GRPCKG1/IN'
  4681.       INTEGER  I, IDENT, J, IX, IY, NBUF,LCHR
  4682.       REAL     RBUF(6)
  4683.       CHARACTER CHR
  4684.       REAL     XSIZE,YSIZE
  4685. C
  4686.       CALL GRSLCT(IDENT)
  4687. C     write (*,*) 'GRSETS: old size', GRXMXA(IDENT), GRYMXA(IDENT)
  4688.       CALL GRPAGE
  4689.       IF ((XSIZE .LT. 0.0) .OR. (YSIZE .LT. 0.0)) THEN
  4690.           CALL GREXEC(GRGTYP, 6,RBUF,NBUF,CHR,LCHR)
  4691.           GRXMXA(IDENT) = RBUF(2)
  4692.           GRYMXA(IDENT) = RBUF(4)
  4693.       ELSE
  4694.           I = NINT(XSIZE)
  4695.           J = NINT(YSIZE)
  4696.           CALL GREXEC(GRGTYP, 2,RBUF,NBUF,CHR,LCHR)
  4697.           IX=RBUF(2)
  4698.           IY=RBUF(4)
  4699.           IF (IX.GT.0) I = MIN(I,IX)
  4700.           IF (IY.GT.0) J = MIN(J,IY)
  4701.           GRXMXA(IDENT) = I
  4702.           GRYMXA(IDENT) = J
  4703.       END IF
  4704. C     write (*,*) 'GRSETS: new size', GRXMXA(IDENT), GRYMXA(IDENT)
  4705.       GRXMIN(IDENT) = 0
  4706.       GRXMAX(IDENT) = GRXMXA(IDENT)
  4707.       GRYMIN(IDENT) = 0
  4708.       GRYMAX(IDENT) = GRYMXA(IDENT)
  4709.       GRADJU(IDENT) = .TRUE.
  4710. C
  4711.       END
  4712. C*GRSFNT -- set text font
  4713. C+
  4714.       SUBROUTINE GRSFNT (IF)
  4715.       INTEGER IF
  4716. C
  4717. C GRPCKG: Set the font for subsequent text plotting.
  4718. C The default font is 1 ("Normal" font); others available are 2
  4719. C ("Roman"), 3 ("Italic"), and 4 ("Script").
  4720. C
  4721. C Argument:
  4722. C  IF (input): the font number to be used for subsequent
  4723. C       text plotting on the current device (in range 1-4).
  4724. C--
  4725. C 19-Mar-1983 - [TJP].
  4726. C  4-Jun-1984 - add code for GMFILE device [TJP].
  4727. C 15-Dec-1988 - change name [TJP].
  4728. C-----------------------------------------------------------------------
  4729.       INCLUDE 'f77.GRPCKG1/IN'
  4730.       INTEGER    I
  4731. C
  4732.       IF (GRCIDE.LT.1) THEN
  4733.           CALL GRWARN('GRSFNT - no graphics device is active.')
  4734.           RETURN
  4735.       END IF
  4736. C
  4737. C Set software font index.
  4738. C
  4739.       IF (IF.LT.1 .OR. IF.GT.4) THEN
  4740.           CALL GRWARN('Illegal font selected: font 1 used.')
  4741.           I = 1
  4742.       ELSE
  4743.           I = IF
  4744.       END IF
  4745. C
  4746. C Ignore request if no change is to be made.
  4747. C
  4748.       IF (IF.EQ.GRCFNT(GRCIDE)) RETURN
  4749. C
  4750. C Save font setting.
  4751. C
  4752.       GRCFNT(GRCIDE) = I
  4753. C
  4754.       END
  4755.  
  4756. C*GRSIZE -- inquire device size and resolution
  4757. C+
  4758.       SUBROUTINE GRSIZE (IDENT,XSZDEF,YSZDEF,XSZMAX,YSZMAX,
  4759.      1                   XPERIN,YPERIN)
  4760. C
  4761. C GRPCKG : obtain device parameters (user-callable routine).
  4762. C--
  4763. C (1-Feb-1983)
  4764. C  5-Aug-1986 - add GREXEC support [AFT].
  4765. C-----------------------------------------------------------------------
  4766.       INCLUDE 'f77.GRPCKG1/IN'
  4767.       INTEGER IDENT
  4768.       REAL XSZDEF, YSZDEF, XSZMAX, YSZMAX, XPERIN, YPERIN
  4769.       INTEGER NBUF,LCHR
  4770.       REAL    RBUF(6)
  4771.       CHARACTER CHR
  4772. C
  4773.       CALL GRSLCT(IDENT)
  4774.       CALL GREXEC(GRGTYP, 6,RBUF,NBUF,CHR,LCHR)
  4775.       XSZDEF = RBUF(2)
  4776.       YSZDEF = RBUF(4)
  4777.       CALL GREXEC(GRGTYP, 2,RBUF,NBUF,CHR,LCHR)
  4778.       XSZMAX = RBUF(2)
  4779.       YSZMAX = RBUF(4)
  4780.       XPERIN = GRPXPI(GRCIDE)
  4781.       YPERIN = GRPYPI(GRCIDE)
  4782. C
  4783.       END
  4784. C*GRSKPB -- skip blanks in character string
  4785. C+
  4786.       SUBROUTINE GRSKPB (S, I)
  4787.       CHARACTER*(*) S
  4788.       INTEGER I
  4789. C
  4790. C GRSKPB: increment I so that it points to the next non-blank
  4791. C character in string S.  'Blank' characters are space and tab (ASCII 
  4792. C character value 9).
  4793. C
  4794. C Arguments:
  4795. C  S      (input)  : character string to be parsed.
  4796. C  I      (in/out) : on input, I is the index of the first character
  4797. C                    in S to be examined; on output, either it points
  4798. C                    to the next non-blank character, or it is equal
  4799. C                    to LEN(S)+1 (if all the rest of the string is 
  4800. C                    blank).
  4801. C--
  4802. C  1985 Oct 8 - New routine, based on SKIPBL (T. J. Pearson).
  4803. C-----------------------------------------------------------------------
  4804. C
  4805.    10 IF (I.GT.LEN(S)) RETURN
  4806.       IF (S(I:I).NE.' ' .AND. S(I:I).NE.CHAR(9)) RETURN
  4807.       I = I+1
  4808.       GOTO 10
  4809.       END
  4810.  
  4811. C*GRSLCT -- select active output device
  4812. C+
  4813.       SUBROUTINE GRSLCT (IDENT)
  4814. C
  4815. C GRPCKG: Check that IDENT is a valid plot identifier, and select the
  4816. C corresponding plot as the current plot. All subsequent plotting will
  4817. C be directed to this device until the assignment is changed by another
  4818. C call to GRSLCT.
  4819. C
  4820. C Argument:
  4821. C
  4822. C IDENT (input, integer): the identifier of the plot to be selected, as
  4823. C       returned by GROPEN.
  4824. C--
  4825. C (1-Feb-1983)
  4826. C  5-Aug-1986 - add GREXEC support [AFT].
  4827. C  4-Jun-1987 - skip action if no change in ID [TJP].
  4828. C 26-Nov-1990 - [TJP].
  4829. C-----------------------------------------------------------------------
  4830.       INCLUDE 'f77.GRPCKG1/IN'
  4831.       REAL     RBUF(6)
  4832.       INTEGER  IDENT, NBUF,LCHR
  4833.       CHARACTER CHR
  4834. C
  4835.       IF ((IDENT.LE.0) .OR. (IDENT.GT.GRIMAX) .OR.
  4836.      1    (GRSTAT(IDENT).EQ.0)) THEN
  4837.             CALL GRWARN('GRSLCT - invalid plot identifier.')
  4838.       ELSE IF (IDENT.EQ.GRCIDE) THEN
  4839.           RETURN
  4840.       ELSE
  4841.           GRCIDE = IDENT
  4842.           GRGTYP = GRTYPE(IDENT)
  4843.           RBUF(1)= GRCIDE
  4844.           RBUF(2)= GRUNIT(GRCIDE)
  4845.           NBUF   = 2
  4846.           CALL GREXEC(GRGTYP, 8,RBUF,NBUF,CHR,LCHR)
  4847.       END IF
  4848.       END
  4849. C*GRSLS -- set line style
  4850. C+
  4851.       SUBROUTINE GRSLS (IS)
  4852.       INTEGER IS
  4853. C
  4854. C GRPCKG: Set the line style for subsequent plotting on the current
  4855. C device. The different line styles are generated in hardware on
  4856. C some devices and by GRPCKG software for the other devices. Five
  4857. C different line styles are available, with the following codes:
  4858. C 1 (full line), 2 (dashed), 3 (dot-dash-dot-dash), 4 (dotted),
  4859. C 5 (dash-dot-dot-dot). The default is 1 (normal full line). Line
  4860. C style is ignored when drawing characters, which are always drawn with
  4861. C a full line.
  4862. C
  4863. C Argument:
  4864. C
  4865. C IS (input, integer): the line-style code for subsequent plotting on
  4866. C       the current device (in range 1-5).
  4867. C--
  4868. C  9-Feb-1983 - [TJP].
  4869. C  3-Jun-1984 - add GMFILE device [TJP].
  4870. C  5-Aug-1986 - add GREXEC support [AFT].
  4871. C 21-Feb-1987 - If needed, calls begin picture [AFT].
  4872. C 19-Jan-1987 - fix bug in GREXEC call [TJP].
  4873. C 16-May-1989 - fix bug for hardware line dash [TJP].
  4874. C  1-Sep-1994 - do not call driver to get size and capabilities [TJP].
  4875. C-----------------------------------------------------------------------
  4876.       INCLUDE 'f77.GRPCKG1/IN'
  4877.       INTEGER I, L, IDASH, NBUF,LCHR
  4878.       REAL    RBUF(6),TMP
  4879.       CHARACTER*10 CHR
  4880.       REAL PATERN(8,5)
  4881. C
  4882.       DATA PATERN/ 8*10.0,
  4883.      1             8*10.0,
  4884.      2             8.0, 6.0, 1.0, 6.0, 8.0, 6.0, 1.0, 6.0,
  4885.      3             1.0, 6.0, 1.0, 6.0, 1.0, 6.0, 1.0, 6.0,
  4886.      4             8.0, 6.0, 1.0, 6.0, 1.0, 6.0, 1.0, 6.0 /
  4887. C
  4888.       IF (GRCIDE.LT.1) THEN
  4889.           CALL GRWARN('GRSLS - no graphics device is active.')
  4890.           RETURN
  4891.       END IF
  4892. C
  4893.       I = IS
  4894.       IF (I.LT.1 .OR. I.GT.5) THEN
  4895.           CALL GRWARN('GRSLS - invalid line-style requested.')
  4896.           I = 1
  4897.       END IF
  4898. C
  4899. C Inquire if hardware dash is available.
  4900. C
  4901.       IDASH=0
  4902.       IF(GRGCAP(GRCIDE)(3:3).EQ.'D') IDASH=1
  4903. C
  4904. C Set up for hardware dash.
  4905. C
  4906.       IF(IDASH.NE.0) THEN
  4907.           GRDASH(GRCIDE) = .FALSE.
  4908.           IF (GRPLTD(GRCIDE)) THEN
  4909.               RBUF(1)=I
  4910.               NBUF=1
  4911.               CALL GREXEC(GRGTYP,19,RBUF,NBUF,CHR,LCHR)
  4912.           END IF
  4913. C
  4914. C Set up for software dash.
  4915. C
  4916.       ELSE
  4917.           IF (I.EQ.1) THEN
  4918.               GRDASH(GRCIDE) = .FALSE.
  4919.           ELSE
  4920.               GRDASH(GRCIDE) = .TRUE.
  4921.               GRIPAT(GRCIDE) = 1
  4922.               GRPOFF(GRCIDE) = 0.0
  4923.               TMP = GRYMXA(GRCIDE)/1000.
  4924.               DO 10 L=1,8
  4925.                   GRPATN(GRCIDE,L) = PATERN(L,I)*TMP
  4926.    10         CONTINUE
  4927.           END IF
  4928.       END IF
  4929.       GRSTYL(GRCIDE) = I
  4930.       END
  4931. C*GRSLW -- set line width
  4932. C+
  4933.       SUBROUTINE GRSLW (IW)
  4934.       INTEGER IW
  4935. C
  4936. C GRPCKG: Set the line width for subsequent plotting on the current
  4937. C device. If the hardware does not support thick lines, they are
  4938. C simulated by tracing each line with multiple strokes offset in the
  4939. C direction perpendicular to the line. The line width is specified by
  4940. C the number of strokes to be used, which must be in the range 1-201.
  4941. C The actual line width obtained depends on the device resolution.
  4942. C If the hardware does support thick lines, the width of the line
  4943. C is approximately 0.005 inches times the value of argument IW.
  4944. C
  4945. C Argument:
  4946. C
  4947. C IW (integer, input): the number of strokes to be used for subsequent
  4948. C       plotting on the current device (in range 1-201).
  4949. C--
  4950. C  1-Feb-1983 [TJP].
  4951. C  3-Jun-1984 [TJP] - add GMFILE device.
  4952. C 28-Aug-1984 [TJP] - correct bug in GMFILE: redundant SET_LINEWIDTH
  4953. C                     commands were not being filtered out.
  4954. C 26-May-1987 [TJP] - add GREXEC support.
  4955. C 11-Jun-1987 [TJP] - remove built-in devices.
  4956. C 31-May-1989 [TJP] - increase maximum width from 21 to 201.
  4957. C  1-Sep-1994 [TJP] 
  4958. C-----------------------------------------------------------------------
  4959.       INCLUDE 'f77.GRPCKG1/IN'
  4960.       INTEGER I, ITHICK
  4961.       REAL    RBUF(1)
  4962.       INTEGER NBUF,LCHR
  4963.       CHARACTER*32 CHR
  4964. C
  4965. C Check that graphics is active.
  4966. C
  4967.       IF (GRCIDE.LT.1) THEN
  4968.           CALL GRWARN('GRSLW - no graphics device is active.')
  4969.           RETURN
  4970.       END IF
  4971. C
  4972. C Check that requested line-width is valid.
  4973. C
  4974.       I = IW
  4975.       IF (I.LT.1 .OR. I.GT.201) THEN
  4976.           CALL GRWARN('GRSLW - invalid line-width requested.')
  4977.           I = 1
  4978.       END IF
  4979. C
  4980. C Ignore the request if the linewidth is unchanged.
  4981. C
  4982.       IF (I.EQ.ABS(GRWIDT(GRCIDE))) RETURN
  4983. C
  4984. C Inquire if hardware supports thick lines.
  4985. C
  4986.       ITHICK = 0
  4987.       IF (GRGCAP(GRCIDE)(5:5).EQ.'T') ITHICK = 1
  4988. C
  4989. C For devices with hardware support of thick lines, send the
  4990. C appropriate commands to the device driver, and give the "current
  4991. C linewidth" parameter a negative value to suppress software linewidth
  4992. C emulation.
  4993. C
  4994.       IF (ITHICK.EQ.1 .AND. GRPLTD(GRCIDE)) THEN
  4995.           RBUF(1) = I
  4996.           CALL GREXEC(GRGTYP,22,RBUF,NBUF,CHR,LCHR)
  4997.       END IF
  4998. C
  4999. C Save the current linewidth.
  5000. C
  5001.       GRWIDT(GRCIDE) = I
  5002.       IF (ITHICK.EQ.1) GRWIDT(GRCIDE) = -I
  5003. C
  5004.       END
  5005. C*GRSYDS -- decode character string into list of symbol numbers
  5006. C+
  5007.       SUBROUTINE GRSYDS (SYMBOL, NSYMBS, TEXT, FONT)
  5008.       INTEGER SYMBOL(*), NSYMBS, FONT
  5009.       CHARACTER*(*) TEXT
  5010. C
  5011. C Given a character string, this routine returns a list of symbol
  5012. C numbers to be used to plot it. It is responsible for interpreting
  5013. C all escape sequences.  Negative `symbol numbers' are inserted in the
  5014. C list to represent pen movement. The following escape sequences are
  5015. C defined (the letter following the \ may be either upper or lower 
  5016. C case):
  5017. C
  5018. C \u       :      up one level (returns -1)
  5019. C \d       :      down one level (returns -2)
  5020. C \b       :      backspace (returns -3)
  5021. C \A       :      (upper case only) Angstrom symbol, roman font
  5022. C \x       :      multiplication sign
  5023. C \.       :      centered dot
  5024. C \\       :      \, returns the code for backslash
  5025. C \gx      :      greek letter corresponding to roman letter x
  5026. C \fn      :      switch to Normal font
  5027. C \fr      :      switch to Roman font
  5028. C \fi      :      switch to Italic font
  5029. C \fs      :      switch to Script font
  5030. C \mn or \mnn :   graph marker number n or nn (1 or 2 digits)
  5031. C \(nnn)   :      Hershey symbol number nnn (any number of digits)
  5032. C
  5033. C Arguments:
  5034. C  SYMBOL (output) : receives the list of symbol numers.
  5035. C  NSYMBS (output) : receives the actual number of symbols specified
  5036. C                    by the string; it is assumed that the dimension of
  5037. C                    SYMBOL is big enough (not less than LEN(TEXT)).
  5038. C  TEXT   (input)  : the text string to be decoded.
  5039. C  FONT   (input)  : the font number (1..4) to be used for decoding the
  5040. C                    string (this can be overridden by an escape
  5041. C                    sequence within the string).
  5042. C--
  5043. C  3-May-1983 - [TJP].
  5044. C 13-Jun-1984 - add \A [TJP].
  5045. C 15-Dec-1988 - standardize [TJP].
  5046. C 29-Nov-1990 - add \m escapes [TJP].
  5047. C 27-Nov-1991 - add \x escape [TJP].
  5048. C 27-Jul-1995 - extend for 256-character set [TJP]
  5049. C  7-Nov-1995 - add \. escape [TJP].
  5050. C-----------------------------------------------------------------------
  5051.       CHARACTER*8  FONTS
  5052.       CHARACTER*48 GREEK
  5053.       PARAMETER (FONTS = 'nrisNRIS')
  5054.       PARAMETER (GREEK = 'ABGDEZYHIKLMNCOPRSTUFXQW' //
  5055.      1                   'abgdezyhiklmncoprstufxqw' )
  5056.       INTEGER  CH, IG, J, LENTXT, IFONT, MARK
  5057. C
  5058. C Initialize parameters.
  5059. C
  5060.       IFONT = FONT
  5061.       LENTXT = LEN(TEXT)
  5062.       NSYMBS = 0
  5063.       J = 0
  5064. C
  5065. C Get next character; treat non-printing characters as spaces.
  5066. C
  5067.   100 J = J+1
  5068.       IF (J.GT.LENTXT) RETURN
  5069.       CH = ICHAR(TEXT(J:J))
  5070.       IF (CH.LT.0)   CH = 32
  5071.       IF (CH.GT.303) CH = 32
  5072. C
  5073. C Test for escape sequence (\)
  5074. C
  5075.       IF (CH.EQ.92) THEN
  5076.           IF ((LENTXT-J).GE.1) THEN
  5077.             IF (TEXT(J+1:J+1).EQ.CHAR(92)) THEN
  5078.                 J = J+1
  5079.             ELSE IF (TEXT(J+1:J+1).EQ.'u' .OR.
  5080.      1                     TEXT(J+1:J+1).EQ.'U') THEN
  5081.                 NSYMBS = NSYMBS + 1
  5082.                 SYMBOL(NSYMBS) = -1
  5083.                 J = J+1
  5084.                 GOTO 100
  5085.             ELSE IF (TEXT(J+1:J+1).EQ.'d' .OR.
  5086.      1                     TEXT(J+1:J+1).EQ.'D') THEN
  5087.                 NSYMBS = NSYMBS + 1
  5088.                 SYMBOL(NSYMBS) = -2
  5089.                 J = J+1
  5090.                 GOTO 100
  5091.             ELSE IF (TEXT(J+1:J+1).EQ.'b' .OR.
  5092.      1                     TEXT(J+1:J+1).EQ.'B') THEN
  5093.                 NSYMBS = NSYMBS + 1
  5094.                 SYMBOL(NSYMBS) = -3
  5095.                 J = J+1
  5096.                 GOTO 100
  5097.             ELSE IF (TEXT(J+1:J+1).EQ.'A') THEN
  5098.                 NSYMBS = NSYMBS + 1
  5099.                 SYMBOL(NSYMBS) = 2078
  5100.                 J = J+1
  5101.                 GOTO 100
  5102.             ELSE IF (TEXT(J+1:J+1).EQ.'x') THEN
  5103.                 NSYMBS = NSYMBS + 1
  5104.                 SYMBOL(NSYMBS) = 2235
  5105.                 IF (IFONT.EQ.1) SYMBOL(NSYMBS) = 727
  5106.                 J = J+1
  5107.                 GOTO 100
  5108.             ELSE IF (TEXT(J+1:J+1).EQ.'.') THEN
  5109.                 NSYMBS = NSYMBS + 1
  5110.                 SYMBOL(NSYMBS) = 2236
  5111.                 IF (IFONT.EQ.1) SYMBOL(NSYMBS) = 729
  5112.                 J = J+1
  5113.                 GOTO 100
  5114.             ELSE IF (TEXT(J+1:J+1).EQ.'(') THEN
  5115.                 NSYMBS = NSYMBS + 1
  5116.                 SYMBOL(NSYMBS) = 0
  5117.                 J = J+2
  5118. C               -- DO WHILE ('0'.LE.TEXT(J:J).AND.TEXT(J:J).LE.'9')
  5119.    90           IF ('0'.LE.TEXT(J:J).AND.TEXT(J:J).LE.'9') THEN
  5120.                   SYMBOL(NSYMBS) = SYMBOL(NSYMBS)*10 +
  5121.      1                      ICHAR(TEXT(J:J)) - ICHAR('0')
  5122.                    J = J+1
  5123.                 GOTO 90
  5124.                 END IF
  5125. C               -- end DO WHILE
  5126.                 IF (TEXT(J:J).NE.')') J = J-1
  5127.                 GOTO 100
  5128.             ELSE IF (TEXT(J+1:J+1).EQ.'m' .OR.
  5129.      1               TEXT(J+1:J+1).EQ.'M') THEN
  5130.                 MARK = 0
  5131.                 J = J+2
  5132.                 IF ('0'.LE.TEXT(J:J).AND.TEXT(J:J).LE.'9') THEN
  5133.                     MARK = MARK*10 + ICHAR(TEXT(J:J)) - ICHAR('0')
  5134.                     J = J+1
  5135.                 END IF
  5136.                 IF ('0'.LE.TEXT(J:J).AND.TEXT(J:J).LE.'9') THEN
  5137.                     MARK = MARK*10 + ICHAR(TEXT(J:J)) - ICHAR('0')
  5138.                     J = J+1
  5139.                 END IF
  5140.                 J = J-1
  5141.                 NSYMBS = NSYMBS + 1
  5142.                 CALL GRSYMK(MARK, IFONT, SYMBOL(NSYMBS))
  5143.                 GOTO 100
  5144.             ELSE IF (TEXT(J+1:J+1).EQ.'f' .OR.
  5145.      1               TEXT(J+1:J+1).EQ.'F') THEN
  5146.                 IFONT = INDEX(FONTS, TEXT(J+2:J+2))
  5147.                 IF (IFONT.GT.4) IFONT = IFONT-4
  5148.                 IF (IFONT.EQ.0) IFONT = 1
  5149.                 J = J+2
  5150.                 GOTO 100
  5151.             ELSE IF (TEXT(J+1:J+1).EQ.'g' .OR.
  5152.      1               TEXT(J+1:J+1).EQ.'G') THEN
  5153.                 IG = INDEX(GREEK, TEXT(J+2:J+2))
  5154.                 NSYMBS = NSYMBS + 1
  5155.                 CALL GRSYMK(255+IG, IFONT, SYMBOL(NSYMBS))
  5156.                 J = J+2
  5157.                 GOTO 100
  5158.             END IF
  5159.           END IF
  5160.       END IF
  5161. C
  5162. C Decode character.
  5163. C
  5164.       NSYMBS = NSYMBS + 1
  5165.       CALL GRSYMK(CH, IFONT, SYMBOL(NSYMBS))
  5166.       GOTO 100
  5167.       END
  5168. C*GRSYMK -- convert character number into symbol number
  5169. C+
  5170.       SUBROUTINE GRSYMK (CODE, FONT, SYMBOL)
  5171.       INTEGER CODE, FONT, SYMBOL
  5172. C
  5173. C This routine returns the Hershey symbol number (SYMBOL) corresponding
  5174. C to ASCII code CODE in font FONT.
  5175. C
  5176. C Characters 0-31 are the same in all fonts, and are the standard
  5177. C graph markers. Characters 32-127 are standard representations of
  5178. C the ASCII codes. Characters 128-255 are reserved for the upper
  5179. C half of the ISO Latin-1 character set. Characters 256-303 are
  5180. C used for the greek alphabet.
  5181. C
  5182. C Arguments:
  5183. C  CODE   (input)  : the extended ASCII code number.
  5184. C  FONT   (input)  : the font to be used 31 (range 1-4).
  5185. C  SYMBOL (output) : the number of the symbol to be plotted.
  5186. C--
  5187. C 24-Apr-1986.
  5188. C 15-Dec-1988 - standardize [TJP].
  5189. C 29-Nov-1990 - eliminate common block [TJP].
  5190. C 27-Nov-1991 - correct code for backslash [TJP].
  5191. C 27-Jul-1995 - extend for 256-character set; add some defaults for
  5192. C               ISO Latin-1 (full glyph set not available) [TJP].
  5193. C-----------------------------------------------------------------------
  5194.       INTEGER   I, K, HERSH(0:303,4)
  5195.       SAVE      HERSH
  5196. C
  5197. C Special characters (graph markers).
  5198. C
  5199.       DATA (HERSH(  0,K),K=1,4) / 841, 841, 841, 841/
  5200.       DATA (HERSH(  1,K),K=1,4) / 899, 899, 899, 899/
  5201.       DATA (HERSH(  2,K),K=1,4) / 845, 845, 845, 845/
  5202.       DATA (HERSH(  3,K),K=1,4) / 847, 847, 847, 847/
  5203.       DATA (HERSH(  4,K),K=1,4) / 840, 840, 840, 840/
  5204.       DATA (HERSH(  5,K),K=1,4) / 846, 846, 846, 846/
  5205.       DATA (HERSH(  6,K),K=1,4) / 841, 841, 841, 841/
  5206.       DATA (HERSH(  7,K),K=1,4) / 842, 842, 842, 842/
  5207.       DATA (HERSH(  8,K),K=1,4) /2284,2284,2284,2284/
  5208.       DATA (HERSH(  9,K),K=1,4) /2281,2281,2281,2281/
  5209.       DATA (HERSH( 10,K),K=1,4) / 735, 735, 735, 735/
  5210.       DATA (HERSH( 11,K),K=1,4) / 843, 843, 843, 843/
  5211.       DATA (HERSH( 12,K),K=1,4) / 844, 844, 844, 844/
  5212.       DATA (HERSH( 13,K),K=1,4) / 852, 852, 852, 852/
  5213.       DATA (HERSH( 14,K),K=1,4) / 866, 866, 866, 866/
  5214.       DATA (HERSH( 15,K),K=1,4) / 868, 868, 868, 868/
  5215.       DATA (HERSH( 16,K),K=1,4) / 851, 851, 851, 851/
  5216.       DATA (HERSH( 17,K),K=1,4) / 850, 850, 850, 850/
  5217.       DATA (HERSH( 18,K),K=1,4) / 856, 856, 856, 856/
  5218.       DATA (HERSH( 19,K),K=1,4) / 254, 254, 254, 254/
  5219.       DATA (HERSH( 20,K),K=1,4) / 900, 900, 900, 900/
  5220.       DATA (HERSH( 21,K),K=1,4) / 901, 901, 901, 901/
  5221.       DATA (HERSH( 22,K),K=1,4) / 902, 902, 902, 902/
  5222.       DATA (HERSH( 23,K),K=1,4) / 903, 903, 903, 903/
  5223.       DATA (HERSH( 24,K),K=1,4) / 904, 904, 904, 904/
  5224.       DATA (HERSH( 25,K),K=1,4) / 905, 905, 905, 905/
  5225.       DATA (HERSH( 26,K),K=1,4) / 906, 906, 906, 906/
  5226.       DATA (HERSH( 27,K),K=1,4) / 907, 907, 907, 907/
  5227.       DATA (HERSH( 28,K),K=1,4) /2263,2263,2263,2263/
  5228.       DATA (HERSH( 29,K),K=1,4) /2261,2261,2261,2261/
  5229.       DATA (HERSH( 30,K),K=1,4) /2262,2262,2262,2262/
  5230.       DATA (HERSH( 31,K),K=1,4) /2264,2264,2264,2264/
  5231. C
  5232. C US-ASCII (ISO Latin-1 lower half).
  5233. C
  5234. C   32:39 space exclam quotdbl numbersign
  5235. C         dollar percent ampersand quoteright
  5236.       DATA (HERSH( 32,K),K=1,4) / 699,2199,2199,2199/
  5237.       DATA (HERSH( 33,K),K=1,4) / 714,2214,2764,2764/
  5238.       DATA (HERSH( 34,K),K=1,4) / 717,2217,2778,2778/
  5239.       DATA (HERSH( 35,K),K=1,4) / 733,2275,2275,2275/
  5240.       DATA (HERSH( 36,K),K=1,4) / 719,2274,2769,2769/
  5241.       DATA (HERSH( 37,K),K=1,4) /2271,2271,2271,2271/
  5242.       DATA (HERSH( 38,K),K=1,4) / 734,2272,2768,2768/
  5243.       DATA (HERSH( 39,K),K=1,4) / 716,2216,2777,2777/
  5244. C   40:47 parenleft parenright asterisk plus
  5245. C         comma minus period slash
  5246.       DATA (HERSH( 40,K),K=1,4) / 721,2221,2771,2771/
  5247.       DATA (HERSH( 41,K),K=1,4) / 722,2222,2772,2772/
  5248.       DATA (HERSH( 42,K),K=1,4) / 728,2219,2773,2773/
  5249.       DATA (HERSH( 43,K),K=1,4) / 725,2232,2775,2775/
  5250.       DATA (HERSH( 44,K),K=1,4) / 711,2211,2761,2761/
  5251.       DATA (HERSH( 45,K),K=1,4) / 724,2231,2774,2774/
  5252.       DATA (HERSH( 46,K),K=1,4) / 710,2210,2760,2760/
  5253.       DATA (HERSH( 47,K),K=1,4) / 720,2220,2770,2770/
  5254. C   48:55 zero one two three four five six seven
  5255.       DATA (HERSH( 48,K),K=1,4) / 700,2200,2750,2750/
  5256.       DATA (HERSH( 49,K),K=1,4) / 701,2201,2751,2751/
  5257.       DATA (HERSH( 50,K),K=1,4) / 702,2202,2752,2752/
  5258.       DATA (HERSH( 51,K),K=1,4) / 703,2203,2753,2753/
  5259.       DATA (HERSH( 52,K),K=1,4) / 704,2204,2754,2754/
  5260.       DATA (HERSH( 53,K),K=1,4) / 705,2205,2755,2755/
  5261.       DATA (HERSH( 54,K),K=1,4) / 706,2206,2756,2756/
  5262.       DATA (HERSH( 55,K),K=1,4) / 707,2207,2757,2757/
  5263. C   56:63 eight nine colon semicolon less equal greater question
  5264.       DATA (HERSH( 56,K),K=1,4) / 708,2208,2758,2758/
  5265.       DATA (HERSH( 57,K),K=1,4) / 709,2209,2759,2759/
  5266.       DATA (HERSH( 58,K),K=1,4) / 712,2212,2762,2762/
  5267.       DATA (HERSH( 59,K),K=1,4) / 713,2213,2763,2763/
  5268.       DATA (HERSH( 60,K),K=1,4) /2241,2241,2241,2241/
  5269.       DATA (HERSH( 61,K),K=1,4) / 726,2238,2776,2776/
  5270.       DATA (HERSH( 62,K),K=1,4) /2242,2242,2242,2242/
  5271.       DATA (HERSH( 63,K),K=1,4) / 715,2215,2765,2765/
  5272. C   64:71 at A B C D E F G
  5273.       DATA (HERSH( 64,K),K=1,4) /2273,2273,2273,2273/
  5274.       DATA (HERSH( 65,K),K=1,4) / 501,2001,2051,2551/
  5275.       DATA (HERSH( 66,K),K=1,4) / 502,2002,2052,2552/
  5276.       DATA (HERSH( 67,K),K=1,4) / 503,2003,2053,2553/
  5277.       DATA (HERSH( 68,K),K=1,4) / 504,2004,2054,2554/
  5278.       DATA (HERSH( 69,K),K=1,4) / 505,2005,2055,2555/
  5279.       DATA (HERSH( 70,K),K=1,4) / 506,2006,2056,2556/
  5280.       DATA (HERSH( 71,K),K=1,4) / 507,2007,2057,2557/
  5281. C   72:79 H I J K L M N O
  5282.       DATA (HERSH( 72,K),K=1,4) / 508,2008,2058,2558/
  5283.       DATA (HERSH( 73,K),K=1,4) / 509,2009,2059,2559/
  5284.       DATA (HERSH( 74,K),K=1,4) / 510,2010,2060,2560/
  5285.       DATA (HERSH( 75,K),K=1,4) / 511,2011,2061,2561/
  5286.       DATA (HERSH( 76,K),K=1,4) / 512,2012,2062,2562/
  5287.       DATA (HERSH( 77,K),K=1,4) / 513,2013,2063,2563/
  5288.       DATA (HERSH( 78,K),K=1,4) / 514,2014,2064,2564/
  5289.       DATA (HERSH( 79,K),K=1,4) / 515,2015,2065,2565/
  5290. C   80:87 P Q R S T U V W
  5291.       DATA (HERSH( 80,K),K=1,4) / 516,2016,2066,2566/
  5292.       DATA (HERSH( 81,K),K=1,4) / 517,2017,2067,2567/
  5293.       DATA (HERSH( 82,K),K=1,4) / 518,2018,2068,2568/
  5294.       DATA (HERSH( 83,K),K=1,4) / 519,2019,2069,2569/
  5295.       DATA (HERSH( 84,K),K=1,4) / 520,2020,2070,2570/
  5296.       DATA (HERSH( 85,K),K=1,4) / 521,2021,2071,2571/
  5297.       DATA (HERSH( 86,K),K=1,4) / 522,2022,2072,2572/
  5298.       DATA (HERSH( 87,K),K=1,4) / 523,2023,2073,2573/
  5299. C   88:95 X Y Z bracketleft 
  5300. C         backslash bracketright asciicircum underscore
  5301.       DATA (HERSH( 88,K),K=1,4) / 524,2024,2074,2574/
  5302.       DATA (HERSH( 89,K),K=1,4) / 525,2025,2075,2575/
  5303.       DATA (HERSH( 90,K),K=1,4) / 526,2026,2076,2576/
  5304.       DATA (HERSH( 91,K),K=1,4) /2223,2223,2223,2223/
  5305.       DATA (HERSH( 92,K),K=1,4) / 804, 804, 804, 804/
  5306.       DATA (HERSH( 93,K),K=1,4) /2224,2224,2224,2224/
  5307.       DATA (HERSH( 94,K),K=1,4) / 718,2218,2779,2779/
  5308.       DATA (HERSH( 95,K),K=1,4) / 590, 590, 590, 590/
  5309. C   96:103 quoteleft a b c d e f g
  5310.       DATA (HERSH( 96,K),K=1,4) /2249,2249,2249,2249/
  5311.       DATA (HERSH( 97,K),K=1,4) / 601,2101,2151,2651/
  5312.       DATA (HERSH( 98,K),K=1,4) / 602,2102,2152,2652/
  5313.       DATA (HERSH( 99,K),K=1,4) / 603,2103,2153,2653/
  5314.       DATA (HERSH(100,K),K=1,4) / 604,2104,2154,2654/
  5315.       DATA (HERSH(101,K),K=1,4) / 605,2105,2155,2655/
  5316.       DATA (HERSH(102,K),K=1,4) / 606,2106,2156,2656/
  5317.       DATA (HERSH(103,K),K=1,4) / 607,2107,2157,2657/
  5318. C  104:111 h i j k l m n o
  5319.       DATA (HERSH(104,K),K=1,4) / 608,2108,2158,2658/
  5320.       DATA (HERSH(105,K),K=1,4) / 609,2109,2159,2659/
  5321.       DATA (HERSH(106,K),K=1,4) / 610,2110,2160,2660/
  5322.       DATA (HERSH(107,K),K=1,4) / 611,2111,2161,2661/
  5323.       DATA (HERSH(108,K),K=1,4) / 612,2112,2162,2662/
  5324.       DATA (HERSH(109,K),K=1,4) / 613,2113,2163,2663/
  5325.       DATA (HERSH(110,K),K=1,4) / 614,2114,2164,2664/
  5326.       DATA (HERSH(111,K),K=1,4) / 615,2115,2165,2665/
  5327. C  112:119 p q r s t u v w
  5328.       DATA (HERSH(112,K),K=1,4) / 616,2116,2166,2666/
  5329.       DATA (HERSH(113,K),K=1,4) / 617,2117,2167,2667/
  5330.       DATA (HERSH(114,K),K=1,4) / 618,2118,2168,2668/
  5331.       DATA (HERSH(115,K),K=1,4) / 619,2119,2169,2669/
  5332.       DATA (HERSH(116,K),K=1,4) / 620,2120,2170,2670/
  5333.       DATA (HERSH(117,K),K=1,4) / 621,2121,2171,2671/
  5334.       DATA (HERSH(118,K),K=1,4) / 622,2122,2172,2672/
  5335.       DATA (HERSH(119,K),K=1,4) / 623,2123,2173,2673/
  5336. C  120:127 x y z braceleft bar braceright asciitilde -
  5337.       DATA (HERSH(120,K),K=1,4) / 624,2124,2174,2674/
  5338.       DATA (HERSH(121,K),K=1,4) / 625,2125,2175,2675/
  5339.       DATA (HERSH(122,K),K=1,4) / 626,2126,2176,2676/
  5340.       DATA (HERSH(123,K),K=1,4) /2225,2225,2225,2225/
  5341.       DATA (HERSH(124,K),K=1,4) / 723,2229,2229,2229/
  5342.       DATA (HERSH(125,K),K=1,4) /2226,2226,2226,2226/
  5343.       DATA (HERSH(126,K),K=1,4) /2246,2246,2246,2246/
  5344.       DATA (HERSH(127,K),K=1,4) / 699,2199,2199,2199/
  5345. C
  5346. C ISO Latin-1 upper half.
  5347. C
  5348. C  128:135 - - - - - - - -
  5349.       DATA (HERSH(128,K),K=1,4) / 699,2199,2199,2199/
  5350.       DATA (HERSH(129,K),K=1,4) / 699,2199,2199,2199/
  5351.       DATA (HERSH(130,K),K=1,4) / 699,2199,2199,2199/
  5352.       DATA (HERSH(131,K),K=1,4) / 699,2199,2199,2199/
  5353.       DATA (HERSH(132,K),K=1,4) / 699,2199,2199,2199/
  5354.       DATA (HERSH(133,K),K=1,4) / 699,2199,2199,2199/
  5355.       DATA (HERSH(134,K),K=1,4) / 699,2199,2199,2199/
  5356.       DATA (HERSH(135,K),K=1,4) / 699,2199,2199,2199/
  5357. C  136:143 - - - - - - - -
  5358.       DATA (HERSH(136,K),K=1,4) / 699,2199,2199,2199/
  5359.       DATA (HERSH(137,K),K=1,4) / 699,2199,2199,2199/
  5360.       DATA (HERSH(138,K),K=1,4) / 699,2199,2199,2199/
  5361.       DATA (HERSH(139,K),K=1,4) / 699,2199,2199,2199/
  5362.       DATA (HERSH(140,K),K=1,4) / 699,2199,2199,2199/
  5363.       DATA (HERSH(141,K),K=1,4) / 699,2199,2199,2199/
  5364.       DATA (HERSH(142,K),K=1,4) / 699,2199,2199,2199/
  5365.       DATA (HERSH(143,K),K=1,4) / 699,2199,2199,2199/
  5366. C   144:151 dotlessi grave acute circumflex tilde - breve dotaccent
  5367.       DATA (HERSH(144,K),K=1,4) / 699,2182,2196,2199/
  5368.       DATA (HERSH(145,K),K=1,4) / 699,2199,2199,2199/
  5369.       DATA (HERSH(146,K),K=1,4) / 699,2199,2199,2199/
  5370.       DATA (HERSH(147,K),K=1,4) / 699,2199,2199,2199/
  5371.       DATA (HERSH(148,K),K=1,4) / 699,2199,2199,2199/
  5372.       DATA (HERSH(149,K),K=1,4) / 699,2199,2199,2199/
  5373.       DATA (HERSH(150,K),K=1,4) / 699,2199,2199,2199/
  5374.       DATA (HERSH(151,K),K=1,4) / 699,2199,2199,2199/
  5375. C   152:159 dieresis - ring - - - - -
  5376.       DATA (HERSH(152,K),K=1,4) / 699,2199,2199,2199/
  5377.       DATA (HERSH(153,K),K=1,4) / 699,2199,2199,2199/
  5378.       DATA (HERSH(154,K),K=1,4) / 699,2199,2199,2199/
  5379.       DATA (HERSH(155,K),K=1,4) / 699,2199,2199,2199/
  5380.       DATA (HERSH(156,K),K=1,4) / 699,2199,2199,2199/
  5381.       DATA (HERSH(157,K),K=1,4) / 699,2199,2199,2199/
  5382.       DATA (HERSH(158,K),K=1,4) / 699,2199,2199,2199/
  5383.       DATA (HERSH(159,K),K=1,4) / 699,2199,2199,2199/
  5384. C   160:167 space exclamdown cent sterling currency yen brokenbar section
  5385.       DATA (HERSH(160,K),K=1,4) / 699,2199,2199,2199/
  5386.       DATA (HERSH(161,K),K=1,4) / 699,2199,2199,2199/
  5387.       DATA (HERSH(162,K),K=1,4) / 910, 910, 910, 910/
  5388.       DATA (HERSH(163,K),K=1,4) / 272, 272, 272, 272/
  5389.       DATA (HERSH(164,K),K=1,4) / 699,2199,2199,2199/
  5390.       DATA (HERSH(165,K),K=1,4) / 699,2199,2199,2199/
  5391.       DATA (HERSH(166,K),K=1,4) / 699,2199,2199,2199/
  5392.       DATA (HERSH(167,K),K=1,4) /2276,2276,2276,2276/
  5393. C   168:175 - copyright - - - - registered -
  5394.       DATA (HERSH(168,K),K=1,4) / 699,2199,2199,2199/
  5395.       DATA (HERSH(169,K),K=1,4) / 274, 274, 274, 274/
  5396.       DATA (HERSH(170,K),K=1,4) / 699,2199,2199,2199/
  5397.       DATA (HERSH(171,K),K=1,4) / 699,2199,2199,2199/
  5398.       DATA (HERSH(172,K),K=1,4) / 699,2199,2199,2199/
  5399.       DATA (HERSH(173,K),K=1,4) / 699,2199,2199,2199/
  5400.       DATA (HERSH(174,K),K=1,4) / 273, 273, 273, 273/
  5401.       DATA (HERSH(175,K),K=1,4) / 699,2199,2199,2199/
  5402. C   176:183 degree plusminus twosuperior threesuperior
  5403. C           acute mu paragraph periodcentered
  5404.       DATA (HERSH(176,K),K=1,4) / 718,2218,2779,2779/
  5405.       DATA (HERSH(177,K),K=1,4) /2233,2233,2233,2233/
  5406.       DATA (HERSH(178,K),K=1,4) / 702,2202,2752,2752/
  5407.       DATA (HERSH(179,K),K=1,4) / 703,2203,2753,2753/
  5408.       DATA (HERSH(180,K),K=1,4) / 699,2199,2199,2199/
  5409.       DATA (HERSH(181,K),K=1,4) / 638,2138,2138,2138/
  5410.       DATA (HERSH(182,K),K=1,4) / 699,2199,2199,2199/
  5411.       DATA (HERSH(183,K),K=1,4) / 729, 729, 729, 729/
  5412. C   184:191 cedilla onesuperior ordmasculine guillemotright
  5413. C           onequarter onehalf threequarters questiondown
  5414.       DATA (HERSH(184,K),K=1,4) / 699,2199,2199,2199/
  5415.       DATA (HERSH(185,K),K=1,4) / 701,2201,2751,2751/
  5416.       DATA (HERSH(186,K),K=1,4) / 699,2199,2199,2199/
  5417.       DATA (HERSH(187,K),K=1,4) / 699,2199,2199,2199/
  5418.       DATA (HERSH(188,K),K=1,4) / 270, 270, 270, 270/
  5419.       DATA (HERSH(189,K),K=1,4) / 261, 261, 261, 261/
  5420.       DATA (HERSH(190,K),K=1,4) / 271, 271, 271, 271/
  5421.       DATA (HERSH(191,K),K=1,4) / 699,2199,2199,2199/
  5422. C   192:199 Agrave Aacute Acircumflex Atilde Aring AE Ccedilla
  5423.       DATA (HERSH(192,K),K=1,4) / 501,2001,2051,2551/
  5424.       DATA (HERSH(193,K),K=1,4) / 501,2001,2051,2551/
  5425.       DATA (HERSH(194,K),K=1,4) / 501,2001,2051,2551/
  5426.       DATA (HERSH(195,K),K=1,4) / 501,2001,2051,2551/
  5427.       DATA (HERSH(196,K),K=1,4) / 501,2001,2051,2551/
  5428.       DATA (HERSH(197,K),K=1,4) / 501,2078,2051,2551/
  5429.       DATA (HERSH(198,K),K=1,4) / 699,2199,2199,2199/
  5430.       DATA (HERSH(199,K),K=1,4) / 503,2003,2053,2553/
  5431. C   200:207 Egrave Eacute Ecircumflex Edieresis 
  5432. C           Igrave Iacute Icircumflex Idieresis
  5433.       DATA (HERSH(200,K),K=1,4) / 505,2005,2055,2555/
  5434.       DATA (HERSH(201,K),K=1,4) / 505,2005,2055,2555/
  5435.       DATA (HERSH(202,K),K=1,4) / 505,2005,2055,2555/
  5436.       DATA (HERSH(203,K),K=1,4) / 505,2005,2055,2555/
  5437.       DATA (HERSH(204,K),K=1,4) / 509,2009,2059,2559/
  5438.       DATA (HERSH(205,K),K=1,4) / 509,2009,2059,2559/
  5439.       DATA (HERSH(206,K),K=1,4) / 509,2009,2059,2559/
  5440.       DATA (HERSH(207,K),K=1,4) / 509,2009,2059,2559/
  5441. C   208:215 Eth Ntilde Ograve Oacute 
  5442. C           Ocircumflex Otilde Odieresis multiply
  5443.       DATA (HERSH(208,K),K=1,4) / 504,2004,2054,2554/
  5444.       DATA (HERSH(209,K),K=1,4) / 514,2014,2064,2564/
  5445.       DATA (HERSH(210,K),K=1,4) / 515,2015,2065,2565/
  5446.       DATA (HERSH(211,K),K=1,4) / 515,2015,2065,2565/
  5447.       DATA (HERSH(212,K),K=1,4) / 515,2015,2065,2565/
  5448.       DATA (HERSH(213,K),K=1,4) / 515,2015,2065,2565/
  5449.       DATA (HERSH(214,K),K=1,4) / 515,2015,2065,2565/
  5450.       DATA (HERSH(215,K),K=1,4) /2235,2235,2235,2235/
  5451. C   216:223 Oslash Ugrave Uacute Ucircumflex
  5452. C           Udieresis Yacute Thorn germandbls
  5453.       DATA (HERSH(216,K),K=1,4) / 515,2015,2065,2565/
  5454.       DATA (HERSH(217,K),K=1,4) / 521,2021,2071,2571/
  5455.       DATA (HERSH(218,K),K=1,4) / 521,2021,2071,2571/
  5456.       DATA (HERSH(219,K),K=1,4) / 521,2021,2071,2571/
  5457.       DATA (HERSH(220,K),K=1,4) / 521,2021,2071,2571/
  5458.       DATA (HERSH(221,K),K=1,4) / 525,2025,2075,2575/
  5459.       DATA (HERSH(222,K),K=1,4) / 699,2199,2199,2199/
  5460.       DATA (HERSH(223,K),K=1,4) / 699,2199,2199,2199/
  5461. C   224:231 agrave aacute acircumflex atilde aring ae ccedilla
  5462.       DATA (HERSH(224,K),K=1,4) / 601,2101,2151,2651/
  5463.       DATA (HERSH(225,K),K=1,4) / 601,2101,2151,2651/
  5464.       DATA (HERSH(226,K),K=1,4) / 601,2101,2151,2651/
  5465.       DATA (HERSH(227,K),K=1,4) / 601,2101,2151,2651/
  5466.       DATA (HERSH(228,K),K=1,4) / 601,2101,2151,2651/
  5467.       DATA (HERSH(229,K),K=1,4) / 601,2101,2151,2651/
  5468.       DATA (HERSH(230,K),K=1,4) / 699,2199,2199,2199/
  5469.       DATA (HERSH(231,K),K=1,4) / 603,2103,2153,2653/
  5470. C   232:239 egrave eacute ecircumflex edieresis 
  5471. C           igrave iacute icircumflex idieresis
  5472.       DATA (HERSH(232,K),K=1,4) / 605,2105,2155,2655/
  5473.       DATA (HERSH(233,K),K=1,4) / 605,2105,2155,2655/
  5474.       DATA (HERSH(234,K),K=1,4) / 605,2105,2155,2655/
  5475.       DATA (HERSH(235,K),K=1,4) / 605,2105,2155,2655/
  5476.       DATA (HERSH(236,K),K=1,4) / 609,2109,2159,2659/
  5477.       DATA (HERSH(237,K),K=1,4) / 609,2109,2159,2659/
  5478.       DATA (HERSH(238,K),K=1,4) / 609,2109,2159,2659/
  5479.       DATA (HERSH(239,K),K=1,4) / 609,2109,2159,2659/
  5480. C   240:247 eth ntilde ograve oacute 
  5481. C           ocircumflex otilde odieresis divide
  5482.       DATA (HERSH(240,K),K=1,4) / 699,2199,2199,2199/
  5483.       DATA (HERSH(241,K),K=1,4) / 614,2114,2164,2664/
  5484.       DATA (HERSH(242,K),K=1,4) / 615,2115,2165,2665/
  5485.       DATA (HERSH(243,K),K=1,4) / 615,2115,2165,2665/
  5486.       DATA (HERSH(244,K),K=1,4) / 615,2115,2165,2665/
  5487.       DATA (HERSH(245,K),K=1,4) / 615,2115,2165,2665/
  5488.       DATA (HERSH(246,K),K=1,4) / 615,2115,2165,2665/
  5489.       DATA (HERSH(247,K),K=1,4) /2237,2237,2237,2237/
  5490. C   248:255 oslash ugrave uacute ucircumflex
  5491. C           udieresis yacute thorn ydieresis
  5492.       DATA (HERSH(248,K),K=1,4) / 615,2115,2165,2665/
  5493.       DATA (HERSH(249,K),K=1,4) / 621,2121,2171,2671/
  5494.       DATA (HERSH(250,K),K=1,4) / 621,2121,2171,2671/
  5495.       DATA (HERSH(251,K),K=1,4) / 621,2121,2171,2671/
  5496.       DATA (HERSH(252,K),K=1,4) / 621,2121,2171,2671/
  5497.       DATA (HERSH(253,K),K=1,4) / 625,2125,2175,2675/
  5498.       DATA (HERSH(254,K),K=1,4) / 699,2199,2199,2199/
  5499.       DATA (HERSH(255,K),K=1,4) / 625,2125,2175,2675/
  5500. C
  5501. C Greek alphabet.
  5502. C
  5503.       DATA (HERSH(256,K),K=1,4) / 527,2027,2027,2027/
  5504.       DATA (HERSH(257,K),K=1,4) / 528,2028,2028,2028/
  5505.       DATA (HERSH(258,K),K=1,4) / 529,2029,2029,2029/
  5506.       DATA (HERSH(259,K),K=1,4) / 530,2030,2030,2030/
  5507.       DATA (HERSH(260,K),K=1,4) / 531,2031,2031,2031/
  5508.       DATA (HERSH(261,K),K=1,4) / 532,2032,2032,2032/
  5509.       DATA (HERSH(262,K),K=1,4) / 533,2033,2033,2033/
  5510.       DATA (HERSH(263,K),K=1,4) / 534,2034,2034,2034/
  5511.       DATA (HERSH(264,K),K=1,4) / 535,2035,2035,2035/
  5512.       DATA (HERSH(265,K),K=1,4) / 536,2036,2036,2036/
  5513.       DATA (HERSH(266,K),K=1,4) / 537,2037,2037,2037/
  5514.       DATA (HERSH(267,K),K=1,4) / 538,2038,2038,2038/
  5515.       DATA (HERSH(268,K),K=1,4) / 539,2039,2039,2039/
  5516.       DATA (HERSH(269,K),K=1,4) / 540,2040,2040,2040/
  5517.       DATA (HERSH(270,K),K=1,4) / 541,2041,2041,2041/
  5518.       DATA (HERSH(271,K),K=1,4) / 542,2042,2042,2042/
  5519.       DATA (HERSH(272,K),K=1,4) / 543,2043,2043,2043/
  5520.       DATA (HERSH(273,K),K=1,4) / 544,2044,2044,2044/
  5521.       DATA (HERSH(274,K),K=1,4) / 545,2045,2045,2045/
  5522.       DATA (HERSH(275,K),K=1,4) / 546,2046,2046,2046/
  5523.       DATA (HERSH(276,K),K=1,4) / 547,2047,2047,2047/
  5524.       DATA (HERSH(277,K),K=1,4) / 548,2048,2048,2048/
  5525.       DATA (HERSH(278,K),K=1,4) / 549,2049,2049,2049/
  5526.       DATA (HERSH(279,K),K=1,4) / 550,2050,2050,2050/
  5527.       DATA (HERSH(280,K),K=1,4) / 627,2127,2127,2127/
  5528.       DATA (HERSH(281,K),K=1,4) / 628,2128,2128,2128/
  5529.       DATA (HERSH(282,K),K=1,4) / 629,2129,2129,2129/
  5530.       DATA (HERSH(283,K),K=1,4) / 630,2130,2130,2130/
  5531.       DATA (HERSH(284,K),K=1,4) / 684,2184,2184,2184/
  5532.       DATA (HERSH(285,K),K=1,4) / 632,2132,2132,2132/
  5533.       DATA (HERSH(286,K),K=1,4) / 633,2133,2133,2133/
  5534.       DATA (HERSH(287,K),K=1,4) / 685,2185,2185,2185/
  5535.       DATA (HERSH(288,K),K=1,4) / 635,2135,2135,2135/
  5536.       DATA (HERSH(289,K),K=1,4) / 636,2136,2136,2136/
  5537.       DATA (HERSH(290,K),K=1,4) / 637,2137,2137,2137/
  5538.       DATA (HERSH(291,K),K=1,4) / 638,2138,2138,2138/
  5539.       DATA (HERSH(292,K),K=1,4) / 639,2139,2139,2139/
  5540.       DATA (HERSH(293,K),K=1,4) / 640,2140,2140,2140/
  5541.       DATA (HERSH(294,K),K=1,4) / 641,2141,2141,2141/
  5542.       DATA (HERSH(295,K),K=1,4) / 642,2142,2142,2142/
  5543.       DATA (HERSH(296,K),K=1,4) / 643,2143,2143,2143/
  5544.       DATA (HERSH(297,K),K=1,4) / 644,2144,2144,2144/
  5545.       DATA (HERSH(298,K),K=1,4) / 645,2145,2145,2145/
  5546.       DATA (HERSH(299,K),K=1,4) / 646,2146,2146,2146/
  5547.       DATA (HERSH(300,K),K=1,4) / 686,2186,2186,2186/
  5548.       DATA (HERSH(301,K),K=1,4) / 648,2148,2148,2148/
  5549.       DATA (HERSH(302,K),K=1,4) / 649,2149,2149,2149/
  5550.       DATA (HERSH(303,K),K=1,4) / 650,2150,2150,2150/
  5551. C
  5552.       IF ((CODE.LT.0) .OR. (CODE.GT.303)) THEN
  5553.           I = 1
  5554.       ELSE
  5555.           I = CODE
  5556.       END IF
  5557.       SYMBOL = HERSH(I,FONT)
  5558. C
  5559.       END
  5560. C*GRTERM -- flush buffer to output device
  5561. C+
  5562.       SUBROUTINE GRTERM
  5563. C
  5564. C GRPCKG: flush the buffer associated with the current plot. GRTERM
  5565. C should be called only when it is necessary to make sure that all the
  5566. C graphics created up to this point in the program are visible on the
  5567. C device, e.g., before beginning a dialog with the user. GRTERM has no
  5568. C effect on hardcopy devices.
  5569. C
  5570. C Arguments: none.
  5571. C--
  5572. C  6-Oct-1983
  5573. C 29-Jan-1985 - add HP2648 device [KS/TJP].
  5574. C 31-Dec-1985 - do not send CAN code to true Tek [TJP/PCP].
  5575. C  5-Aug-1986 - add GREXEC support [AFT].
  5576. C 11-Jun-1987 - remove built-in devices [TJP].
  5577. C-----------------------------------------------------------------------
  5578.       INCLUDE 'f77.GRPCKG1/IN'
  5579.       INTEGER NBUF,LCHR
  5580.       REAL    RBUF(6)
  5581.       CHARACTER CHR
  5582. C
  5583.       IF (GRCIDE.GE.1) THEN
  5584.           CALL GREXEC(GRGTYP,16,RBUF,NBUF,CHR,LCHR)
  5585.       END IF
  5586.       END
  5587. C*GRTEXT -- draw text
  5588. C+
  5589.       SUBROUTINE GRTEXT (CENTER,ORIENT,ABSXY,X0,Y0,STRING)
  5590. C
  5591. C GRPCKG: Write a text string using the high-quality character set.
  5592. C The text is NOT windowed in the current viewport, but may extend over
  5593. C the whole view surface.  Line attributes (color, intensity thickness)
  5594. C apply to text, but line-style is ignored.  The current pen position
  5595. C after a call to GRTEXT is undefined.
  5596. C
  5597. C Arguments:
  5598. C
  5599. C STRING (input, character): the character string to be plotted. This
  5600. C       may include standard escape-sequences to represent non-ASCII
  5601. C       characters and special commands. The number of characters in
  5602. C       STRING (i.e., LEN(STRING)) should not exceed 256.
  5603. C--
  5604. C (3-May-1983)
  5605. C  5-Aug-1986 - add GREXEC support [AFT].
  5606. C  6-Sep-1989 - standardize [TJP].
  5607. C 20-Apr-1995 - Verbose PS file support.  If PGPLOT_PS_VERBOSE_TEXT is
  5608. C               defined, text strings in PS files are preceded by a 
  5609. C               comment with the text of the string plotted as vectors
  5610. C               [TJP after D.S.Briggs].
  5611. C-----------------------------------------------------------------------
  5612.       INCLUDE 'f77.GRPCKG1/IN'
  5613.       LOGICAL ABSXY,UNUSED,VISBLE,CENTER
  5614.       INTEGER XYGRID(300)
  5615.       INTEGER LIST(256)
  5616.       CHARACTER*(*) STRING
  5617.       REAL ANGLE, FACTOR, FNTBAS, FNTFAC, COSA, SINA, DX, DY, XORG, YORG
  5618.       REAL XCUR, YCUR, ORIENT, RATIO, X0, Y0, RLX, RLY
  5619.       REAL XMIN, XMAX, YMIN, YMAX
  5620.       INTEGER I, IFNTLV,NLIST,LX,LY, K, LXLAST,LYLAST, LSTYLE
  5621.       INTEGER SLEN, GRTRIM
  5622.       INTRINSIC ABS, COS, LEN, MIN, SIN
  5623.       CHARACTER DEVTYP*14, STEMP*258
  5624.       LOGICAL DEVINT, VTEXT
  5625. C
  5626. C Check that there is something to be plotted.
  5627. C
  5628.       IF (LEN(STRING).LE.0) RETURN
  5629. C
  5630. C Check that a device is selected.
  5631. C
  5632.       IF (GRCIDE.LT.1) THEN
  5633.           CALL GRWARN('GRTEXT - no graphics device is active.')
  5634.           RETURN
  5635.       END IF
  5636. C
  5637. C Save current line-style, and set style "normal".
  5638. C
  5639.       CALL GRQLS(LSTYLE)
  5640.       CALL GRSLS(1)
  5641. C
  5642. C Put device dependent code here or at end
  5643. C
  5644.       VTEXT = .FALSE.
  5645.       CALL GRQTYP (DEVTYP, DEVINT)
  5646.       IF ((DEVTYP.EQ.'PS').OR.(DEVTYP.EQ.'VPS').OR.
  5647.      1    (DEVTYP.EQ.'CPS').OR.(DEVTYP.EQ.'VCPS')) THEN
  5648.          CALL GRGENV ('PS_VERBOSE_TEXT', STEMP, I)
  5649.          VTEXT = (I.GT.0)
  5650.          IF (VTEXT) THEN
  5651.             SLEN = GRTRIM(STRING)
  5652.             STEMP = '% Start "' // STRING(1:SLEN) // '"'
  5653.             CALL GREXEC (GRGTYP, 23, 0.0, 0, STEMP, SLEN+10)
  5654.          END IF
  5655.       END IF
  5656. C
  5657. C Save current viewport, and open the viewport to include the full
  5658. C view surface.
  5659. C
  5660.       XORG = GRXPRE(GRCIDE)
  5661.       YORG = GRYPRE(GRCIDE)
  5662.       XMIN = GRXMIN(GRCIDE)
  5663.       XMAX = GRXMAX(GRCIDE)
  5664.       YMIN = GRYMIN(GRCIDE)
  5665.       YMAX = GRYMAX(GRCIDE)
  5666.       CALL GRAREA(GRCIDE, 0.0, 0.0, 0.0, 0.0)
  5667. C
  5668. C Compute scaling and orientation.
  5669. C
  5670.       ANGLE = ORIENT*(3.14159265/180.)
  5671.       FACTOR = GRCFAC(GRCIDE)/2.5
  5672.       RATIO = GRPXPI(GRCIDE)/GRPYPI(GRCIDE)
  5673.       COSA = FACTOR * COS(ANGLE)
  5674.       SINA = FACTOR * SIN(ANGLE)
  5675.       CALL GRTXY0(ABSXY, X0, Y0, XORG, YORG)
  5676.       FNTBAS = 0.0
  5677.       FNTFAC = 1.0
  5678.       IFNTLV = 0
  5679.       DX = 0.0
  5680.       DY = 0.0
  5681. C
  5682. C Convert the string to a list of symbol numbers; to prevent overflow
  5683. C of array LIST, the length of STRING is limited to 256 characters.
  5684. C
  5685.       CALL GRSYDS(LIST,NLIST,STRING(1:MIN(256,LEN(STRING))),
  5686.      1             GRCFNT(GRCIDE))
  5687. C
  5688. C Plot the string of characters
  5689. C
  5690.       DO 380 I = 1,NLIST
  5691.           IF (LIST(I).LT.0) THEN
  5692.               IF (LIST(I).EQ.-1) THEN
  5693. C                 ! up
  5694.                   IFNTLV = IFNTLV+1
  5695.                   FNTBAS = FNTBAS + 16.0*FNTFAC
  5696.                   FNTFAC = 0.75**ABS(IFNTLV)
  5697.               ELSE IF (LIST(I).EQ.-2) THEN
  5698. C                 ! down
  5699.                   IFNTLV = IFNTLV-1
  5700.                   FNTFAC = 0.75**ABS(IFNTLV)
  5701.                   FNTBAS = FNTBAS - 16.0*FNTFAC
  5702.               ELSE IF (LIST(I).EQ.-3) THEN
  5703. C                 ! backspace
  5704.                   XORG = XORG - DX*FNTFAC
  5705.                   YORG = YORG - DY*FNTFAC
  5706.               END IF
  5707.               GOTO 380
  5708.           END IF
  5709.           CALL GRSYXD(LIST(I),XYGRID,UNUSED)
  5710.           VISBLE = .FALSE.
  5711.           LX = XYGRID(5)-XYGRID(4)
  5712.           DX = COSA*LX*RATIO
  5713.           DY = SINA*LX
  5714.           K = 4
  5715.           LXLAST = -64
  5716.           LYLAST = -64
  5717.   320     K = K+2
  5718.           LX = XYGRID(K)
  5719.           LY = XYGRID(K+1)
  5720.           IF (LY.EQ.-64) GOTO 330
  5721.           IF (LX.EQ.-64) THEN
  5722.               VISBLE = .FALSE.
  5723.           ELSE
  5724.               RLX = (LX - XYGRID(4))*FNTFAC
  5725.               RLY = (LY - XYGRID(2))*FNTFAC + FNTBAS
  5726.               IF ((LX.NE.LXLAST) .OR. (LY.NE.LYLAST)) THEN
  5727.                   XCUR = XORG + (COSA*RLX - SINA*RLY)*RATIO
  5728.                   YCUR = YORG + (SINA*RLX + COSA*RLY)
  5729.                   IF (VISBLE) THEN
  5730.                       CALL GRLIN0(XCUR,YCUR)
  5731.                   ELSE
  5732.                       GRXPRE(GRCIDE) = XCUR
  5733.                       GRYPRE(GRCIDE) = YCUR
  5734.                   END IF
  5735.               END IF
  5736.               VISBLE = .TRUE.
  5737.               LXLAST = LX
  5738.               LYLAST = LY
  5739.           END IF
  5740.           GOTO 320
  5741.   330     XORG = XORG + DX*FNTFAC
  5742.           YORG = YORG + DY*FNTFAC
  5743.   380 CONTINUE
  5744. C
  5745. C Another possible device dependent section
  5746. C
  5747.       IF (VTEXT) THEN
  5748.          STEMP = '% End "' // STRING(1:SLEN) // '"'
  5749.          CALL GREXEC(GRGTYP, 23, 0.0, 0, STEMP, SLEN+8)
  5750.       END IF
  5751. C
  5752. C Restore the viewport and line-style, and return.
  5753. C
  5754.       GRXMIN(GRCIDE) = XMIN
  5755.       GRXMAX(GRCIDE) = XMAX
  5756.       GRYMIN(GRCIDE) = YMIN
  5757.       GRYMAX(GRCIDE) = YMAX
  5758.       CALL GRSLS(LSTYLE)
  5759. C
  5760.       END
  5761.  
  5762. C*GRTOUP -- convert character string to upper case
  5763. C+
  5764.       SUBROUTINE GRTOUP (DST, SRC)
  5765.       CHARACTER*(*) DST, SRC
  5766. C
  5767. C GRPCKG (internal routine): convert character string to upper case.
  5768. C
  5769. C Arguments:
  5770. C  DST    (output) : output string (upper case).
  5771. C  SRC    (input)  : input string to be converted.
  5772. C--
  5773. C 1988-Jan-18 (TJP)
  5774. C-----------------------------------------------------------------------
  5775.       INTEGER I, N, NCHI, NCHO, NCH
  5776.       NCHI = LEN(SRC)
  5777.       NCHO = LEN(DST)
  5778.       NCH = MIN(NCHI, NCHO)
  5779.       DO 10 I=1,NCH
  5780.           N = ICHAR(SRC(I:I))
  5781.           IF ((N .GE. 97) .AND. (N .LE. 122)) THEN
  5782.               DST(I:I) = CHAR(N - 32)
  5783.           ELSE
  5784.               DST(I:I) = CHAR(N)
  5785.           END IF
  5786.    10 CONTINUE
  5787.       IF (NCHO .GT. NCHI) DST(NCHI+1:NCHO) = ' '
  5788.       END
  5789.  
  5790. C*GRTRAN -- define scaling transformation
  5791. C+
  5792.       SUBROUTINE GRTRAN (IDENT,XORG,YORG,XSCALE,YSCALE)
  5793. C
  5794. C GRPCKG (internal routine): Define scaling transformation.
  5795. C
  5796. C Arguments:
  5797. C
  5798. C IDENT (input, integer): plot identifier, as returned by GROPEN.
  5799. C XORG, YORG, XSCALE, YSCALE (input, real): parameters of the scaling
  5800. C       transformation. This is defined by:
  5801. C               XABS = XORG + XWORLD * XSCALE,
  5802. C               YABS = YORG + YWORLD * YSCALE,
  5803. C       where (XABS, YABS) are the absolute device coordinates
  5804. C       corresponding to world coordinates (XWORLD, YWORLD).
  5805. C--
  5806. C (1-Feb-1983)
  5807. C-----------------------------------------------------------------------
  5808.       INTEGER  IDENT
  5809.       REAL     XORG, YORG, XSCALE, YSCALE
  5810. C
  5811.       CALL GRSLCT(IDENT)
  5812.       CALL GRTRN0(XORG, YORG, XSCALE, YSCALE)
  5813. C
  5814.       END
  5815. C*GRTRN0 -- define scaling transformation
  5816. C+
  5817.       SUBROUTINE GRTRN0 (XORG,YORG,XSCALE,YSCALE)
  5818. C
  5819. C GRPCKG (internal routine): Define scaling transformation for current
  5820. C device (equivalent to GRTRAN without device selection).
  5821. C
  5822. C Arguments:
  5823. C
  5824. C XORG, YORG, XSCALE, YSCALE (input, real): parameters of the scaling
  5825. C       transformation. This is defined by:
  5826. C               XABS = XORG + XWORLD * XSCALE,
  5827. C               YABS = YORG + YWORLD * YSCALE,
  5828. C       where (XABS, YABS) are the absolute device coordinates
  5829. C       corresponding to world coordinates (XWORLD, YWORLD).
  5830. C--
  5831. C  1-Feb-83:
  5832. C 11-Feb-92: Add driver support (TJP).
  5833. C  1-Sep-94: Suppress driver call (TJP).
  5834. C-----------------------------------------------------------------------
  5835.       INCLUDE 'f77.GRPCKG1/IN'
  5836.       REAL     XORG, YORG, XSCALE, YSCALE
  5837.       REAL           RBUF(6)
  5838.       INTEGER        NBUF,LCHR
  5839.       CHARACTER*16   CHR
  5840. C
  5841.       GRXORG(GRCIDE) = XORG
  5842.       GRXSCL(GRCIDE) = XSCALE
  5843.       GRYORG(GRCIDE) = YORG
  5844.       GRYSCL(GRCIDE) = YSCALE
  5845. C
  5846. C Pass info to device driver?
  5847. C
  5848.       IF (GRGCAP(GRCIDE)(2:2).EQ.'X') THEN
  5849.           RBUF(1) = XORG
  5850.           RBUF(2) = XSCALE
  5851.           RBUF(3) = YORG
  5852.           RBUF(4) = YSCALE
  5853.           NBUF = 4
  5854.           LCHR = 0
  5855.           CALL GREXEC(GRGTYP,27,RBUF,NBUF,CHR,LCHR)
  5856.       END IF
  5857. C
  5858.       END
  5859.  
  5860. C*GRTXY0 -- convert world coordinates to device coordinates
  5861. C+
  5862.       SUBROUTINE GRTXY0 (ABSXY,X,Y,XT,YT)
  5863. C
  5864. C GRPCKG (internal routine): Convert scaled position to absolute
  5865. C position.
  5866. C
  5867. C Arguments:
  5868. C
  5869. C ABSXY (input, logical): if FALSE, convert world coordinates to
  5870. C       absolute device coordinates; if TRUE, return the input
  5871. C       coordinates unchanged.
  5872. C X, Y (input, real): input coordinates (absolute or world, depending
  5873. C       on setting of ABSXY).
  5874. C XT, YT (output, real): output absolute device coordinates.
  5875. C--
  5876. C (1-Feb-1983)
  5877. C-----------------------------------------------------------------------
  5878.       INCLUDE 'f77.GRPCKG1/IN'
  5879.       LOGICAL  ABSXY
  5880.       REAL     X, Y, XT, YT
  5881. C
  5882.       IF (ABSXY) THEN
  5883.           XT = X
  5884.           YT = Y
  5885.       ELSE
  5886.           XT = X * GRXSCL(GRCIDE) + GRXORG(GRCIDE)
  5887.           YT = Y * GRYSCL(GRCIDE) + GRYORG(GRCIDE)
  5888.       END IF
  5889. C
  5890.       END
  5891.  
  5892. C*GRVCT0 -- draw line segments or dots
  5893. C+
  5894.       SUBROUTINE GRVCT0 (MODE,ABSXY,POINTS,X,Y)
  5895. C
  5896. C GRPCKG (internal routine): Draw a line or a set of dots. This
  5897. C is the same as GRVECT, but without device selection. It can be used to
  5898. C draw a single line-segment, a continuous series of line segments, or
  5899. C one or more single dots (pixels).
  5900. C
  5901. C Arguments:
  5902. C
  5903. C MODE (input, integer): if MODE=1, a series of line segments is drawn,
  5904. C       starting at the current position, moving to X(1),Y(1), ... and
  5905. C       ending at X(POINTS),Y(POINTS).
  5906. C       If MODE=2, the first vector is blanked, so the line starts at
  5907. C       X(1),Y(1).
  5908. C       If MODE=3, a single dot is placed at each coordinate pair, with
  5909. C       no connecting lines.
  5910. C ABSXY (input, logical): if TRUE, the coordinates are absolute device
  5911. C       coordinates; if FALSE, they are world coordinates and the
  5912. C       scaling transformation is applied.
  5913. C POINTS (input, integer): the number of coordinate pairs.
  5914. C X, Y (input, real arrays, dimensioned POINTS or greater): the
  5915. C       X and Y coordinates of the points.
  5916. C--
  5917. C (1-Feb-1983)
  5918. C-----------------------------------------------------------------------
  5919.       INCLUDE 'f77.GRPCKG1/IN'
  5920.       INTEGER  I, MODE, POINTS
  5921.       LOGICAL  ABSXY
  5922.       REAL     X(POINTS), Y(POINTS), XCUR, YCUR
  5923. C
  5924.       IF (MODE.EQ.1) THEN
  5925.           CALL GRTXY0(ABSXY, X(1), Y(1), XCUR, YCUR)
  5926.           CALL GRLIN0(XCUR, YCUR)
  5927.       ELSE IF (MODE.EQ.2) THEN
  5928.           CALL GRTXY0(ABSXY, X(1), Y(1), GRXPRE(GRCIDE), GRYPRE(GRCIDE))
  5929.       END IF
  5930.       IF (MODE.EQ.1 .OR. MODE.EQ.2) THEN
  5931.           DO 10 I=2,POINTS
  5932.               CALL GRTXY0(ABSXY, X(I), Y(I), XCUR, YCUR)
  5933.               CALL GRLIN0(XCUR, YCUR)
  5934.    10     CONTINUE
  5935.       ELSE IF (MODE.EQ.3) THEN
  5936.           DO 20 I=1,POINTS
  5937.               CALL GRTXY0(ABSXY, X(I), Y(I), XCUR, YCUR)
  5938.               CALL GRDOT0(XCUR, YCUR)
  5939.    20     CONTINUE
  5940.       END IF
  5941. C
  5942.       END
  5943.  
  5944. C*GRVECT -- draw line segments or dots
  5945. C+
  5946.       SUBROUTINE GRVECT (IDENT,MODE,ABSXY,POINTS,X,Y)
  5947. C
  5948. C GRPCKG: Draw a line or a set of dots. This routine can be used to
  5949. C draw a single line-segment, a continuous series of line segments, or
  5950. C one or more single dots (pixels).
  5951. C
  5952. C Arguments:
  5953. C
  5954. C IDENT (input, integer): the plot identifier, as returned by GROPEN.
  5955. C MODE (input, integer): if MODE=1, a series of line segments is drawn,
  5956. C       starting at the current position, moving to X(1),Y(1), ... and
  5957. C       ending at X(POINTS),Y(POINTS).
  5958. C       If MODE=2, the first vector is blanked, so the line starts at
  5959. C       X(1),Y(1).
  5960. C       If MODE=3, a single dot is placed at each coordinate pair, with
  5961. C       no connecting lines.
  5962. C ABSXY (input, logical): if TRUE, the coordinates are absolute device
  5963. C       coordinates; if FALSE, they are world coordinates and the
  5964. C       scaling transformation is applied.
  5965. C POINTS (input, integer): the number of coordinate pairs.
  5966. C X, Y (input, real arrays, dimensioned POINTS or greater): the
  5967. C       X and Y coordinates of the points.
  5968. C--
  5969. C (1-Feb-1983)
  5970. C-----------------------------------------------------------------------
  5971.       INTEGER  IDENT, MODE, POINTS
  5972.       LOGICAL  ABSXY
  5973.       REAL     X(POINTS), Y(POINTS)
  5974. C
  5975.       CALL GRSLCT(IDENT)
  5976.       IF (MODE.LE.0 .OR. MODE.GT.3) THEN
  5977.           CALL GRWARN('GRVECT - invalid MODE parameter.')
  5978.       ELSE IF (POINTS.GT.0) THEN
  5979.           CALL GRVCT0(MODE, ABSXY, POINTS, X, Y)
  5980.       END IF
  5981. C
  5982.       END
  5983. C*GRWARN -- issue warning message to user
  5984. C+
  5985.       SUBROUTINE GRWARN (TEXT)
  5986.       CHARACTER*(*) TEXT
  5987. C
  5988. C Report a warning message on standard output, with prefix "%PGPLOT, ".
  5989. C
  5990. C Argument:
  5991. C  TEXT (input): text of message to be printed (the string
  5992. C      may not be blank).
  5993. C--
  5994. C  8-Nov-1994 [TJP]
  5995. C-----------------------------------------------------------------------
  5996.       INTEGER   GRTRIM
  5997. C
  5998.       IF (TEXT.NE.' ') THEN
  5999.           WRITE (*, '(1X,2A)') '%PGPLOT, ', TEXT(1:GRTRIM(TEXT))
  6000.       END IF
  6001.       END
  6002. C*GRXHLS -- convert RGB color to HLS color
  6003. C+
  6004.       SUBROUTINE GRXHLS (R,G,B,H,L,S)
  6005. C
  6006. C GRPCKG: Convert a color specified in the RGB color model to one in
  6007. C the HLS model.  This is a support routine: no graphics I/O occurs.
  6008. C The inverse transformation is accomplished with routine GRXRGB.
  6009. C Reference: SIGGRAPH Status Report of the Graphic Standards Planning
  6010. C Committee, Computer Graphics, Vol.13, No.3, Association for
  6011. C Computing Machinery, New York, NY, 1979.
  6012. C
  6013. C Arguments:
  6014. C
  6015. C R,G,B (real, input): red, green, blue color coordinates, each in the
  6016. C       range 0.0 to 1.0. Input outside this range causes HLS = (0,1,0)
  6017. C       [white] to be returned.
  6018. C H,L,S (real, output): hue (0 to 360), lightness (0 to 1.0), and
  6019. C       saturation (0 to 1.0).
  6020. C--
  6021. C  2-Jul-1984 - new routine [TJP].
  6022. C 29-Sep-1994 - force H to be in rnage 0-360 [Remko Scharroo; TJP].
  6023. C-----------------------------------------------------------------------
  6024.       REAL     R,G,B, H,L,S, MA, MI, RR, GG, BB, D
  6025. C
  6026.       H = 0.0
  6027.       L = 1.0
  6028.       S = 0.0
  6029.       MA = MAX(R,G,B)
  6030.       MI = MIN(R,G,B)
  6031.       IF (MA.GT.1.0 .OR. MI.LT.0.0) RETURN
  6032.       RR = (MA-R)
  6033.       GG = (MA-G)
  6034.       BB = (MA-B)
  6035. C
  6036. C Lightness
  6037. C
  6038.       L = 0.5*(MA+MI)
  6039. C
  6040. C Achromatic case (R=G=B)
  6041. C
  6042.       IF (MA.EQ.MI) THEN
  6043.           S = 0.0
  6044.           H = 0.0
  6045. C
  6046. C Chromatic case
  6047. C
  6048.       ELSE
  6049. C         -- Saturation
  6050.           D = MA-MI
  6051.           IF (L.LE.0.5) THEN
  6052.               S = D/(MA+MI)
  6053.           ELSE
  6054.               S = D/(2.0-MA-MI)
  6055.           END IF
  6056. C         -- Hue
  6057.           IF (R.EQ.MA) THEN
  6058. C             -- yellow to magenta
  6059.               H = (2.0*D+BB-GG)
  6060.           ELSE IF (G.EQ.MA) THEN
  6061.               H = (4.0*D+RR-BB)
  6062.           ELSE
  6063. C             ! (B.EQ.MA)
  6064.               H = (6.0*D+GG-RR)
  6065.           END IF
  6066.           H = MOD(H*60.0/D,360.0)
  6067.           IF (H.LT.0.0) H = H+360.0
  6068.       END IF
  6069. C
  6070.       END
  6071. C*GRXRGB -- convert HLS color to RGB color
  6072. C+
  6073.       SUBROUTINE GRXRGB (H,L,S,R,G,B)
  6074. C
  6075. C GRPCKG: Convert a color specified in the HLS color model to one in
  6076. C the RGB model.  This is a support routine: no graphics I/O occurs.
  6077. C The inverse transformation is accomplished with routine GRXHLS.
  6078. C Reference: SIGGRAPH Status Report of the Graphic Standards Planning
  6079. C Committee, Computer Graphics, Vol.13, No.3, Association for
  6080. C Computing Machinery, New York, NY, 1979.
  6081. C
  6082. C Arguments:
  6083. C
  6084. C H,L,S (real, input): hue (0 to 360), lightness (0 to 1.0), and
  6085. C       saturation (0 to 1.0).
  6086. C R,G,B (real, output): red, green, blue color coordinates, each in the
  6087. C       range 0.0 to 1.0.
  6088. C--
  6089. C  2-Jul-1984 - new routine [TJP].
  6090. C 29-Sep-1994 - take H module 360 [TJP].
  6091. C-----------------------------------------------------------------------
  6092.       REAL     H,L,S, R,G,B, MA, MI, HM
  6093. C
  6094.       HM = MOD(H, 360.0)
  6095.       IF (HM.LT.0.0) HM = HM+360.0
  6096.       IF (L.LE.0.5) THEN
  6097.           MA = L*(1.+S)
  6098.       ELSE
  6099.           MA = L + S - L*S
  6100.       END IF
  6101.       MI = 2*L-MA
  6102. C
  6103. C R component
  6104. C
  6105.       IF (HM.LT.60.0) THEN
  6106.           R = MI + (MA-MI)*HM/60.0
  6107.       ELSE IF (HM.LT.180.0) THEN
  6108.           R = MA
  6109.       ELSE IF (HM.LT.240.0) THEN
  6110.           R = MI + (MA-MI)*(240.0-HM)/60.0
  6111.       ELSE
  6112.           R = MI
  6113.       END IF
  6114. C
  6115. C G component
  6116. C
  6117.       IF (HM.LT.120.0) THEN
  6118.           G = MI
  6119.       ELSE IF (HM.LT.180.0) THEN
  6120.           G = MI + (MA-MI)*(HM-120.0)/60.0
  6121.       ELSE IF (HM.LT.300.0) THEN
  6122.           G = MA
  6123.       ELSE
  6124.           G = MI + (MA-MI)*(360.0-HM)/60.0
  6125.       END IF
  6126. C
  6127. C B component
  6128. C
  6129.       IF (HM.LT.60.0 .OR. HM.GE.300.0) THEN
  6130.           B = MA
  6131.       ELSE IF (HM.LT.120.0) THEN
  6132.           B = MI + (MA-MI)*(120.0-HM)/60.0
  6133.       ELSE IF (HM.LT.240.0) THEN
  6134.           B = MI
  6135.       ELSE
  6136.           B = MI + (MA-MI)*(HM-240.0)/60.0
  6137.       END IF
  6138. C
  6139.       END
  6140. C*PGADVANCE -- non-standard alias for PGPAGE
  6141. C+
  6142.       SUBROUTINE PGADVANCE
  6143. C
  6144. C See description of PGPAGE.
  6145. C--
  6146.       CALL PGPAGE
  6147.       END
  6148. C*PGARRO -- draw an arrow
  6149. C%void cpgarro(float x1, float y1, float x2, float y2);
  6150. C+
  6151.       SUBROUTINE PGARRO (X1, Y1, X2, Y2)
  6152.       REAL X1, Y1, X2, Y2
  6153. C
  6154. C Draw an arrow from the point with world-coordinates (X1,Y1) to 
  6155. C (X2,Y2). The size of the arrowhead at (X2,Y2) is determined by 
  6156. C the current character size set by routine PGSCH. The default size 
  6157. C is 1/40th of the smaller of the width or height of the view surface.
  6158. C The appearance of the arrowhead (shape and solid or open) is
  6159. C controlled by routine PGSAH.
  6160. C
  6161. C Arguments:
  6162. C  X1, Y1 (input)  : world coordinates of the tail of the arrow.
  6163. C  X2, Y2 (input)  : world coordinates of the head of the arrow.
  6164. C--
  6165. C  7-Feb-92 Keith Horne @ STScI / TJP.
  6166. C 13-Oct-92 - use arrowhead attributes; scale (TJP).
  6167. C-----------------------------------------------------------------------
  6168.       INTEGER AHFS, FS
  6169.       REAL DX, DY, XV1, XV2, YV1, YV2, XL, XR, YB, YT, DINDX, DINDY
  6170.       REAL XINCH, YINCH, RINCH, CA, SA, SO, CO, YP, XP, YM, XM, DHX, DHY
  6171.       REAL PX(4), PY(4)
  6172.       REAL AHANGL, AHVENT, SEMANG, CH, DH, XS1, XS2, YS1, YS2
  6173. C
  6174.       CALL PGBBUF
  6175.       CALL PGQAH(AHFS, AHANGL, AHVENT)
  6176.       CALL PGQFS(FS)
  6177.       CALL PGSFS(AHFS)
  6178.       DX = X2 - X1
  6179.       DY = Y2 - Y1
  6180.       CALL PGQCH(CH)
  6181.       CALL PGQVSZ(1, XS1, XS2, YS1, YS2)
  6182. C     -- length of arrowhead: 1 40th of the smaller of the height or
  6183. C        width of the view surface, scaled by character height.
  6184.       DH = CH*MIN(ABS(XS2-XS1),ABS(YS2-YS1))/40.0
  6185.       CALL PGMOVE(X2, Y2)
  6186. C     -- Is there to be an arrowhead ?
  6187.       IF (DH.GT.0.) THEN
  6188.           IF (DX.NE.0. .OR. DY.NE.0.) THEN
  6189. C             -- Get x and y scales
  6190.               CALL PGQVP(1, XV1, XV2, YV1, YV2)
  6191.               CALL PGQWIN(XL, XR, YB, YT)
  6192.               IF (XR.NE.XL .AND. YT.NE.YB) THEN
  6193.                   DINDX = (XV2 - XV1) / (XR - XL)
  6194.                   DINDY = (YV2 - YV1) / (YT - YB)
  6195.                   DHX = DH / DINDX
  6196.                   DHY = DH / DINDY
  6197. C                 -- Unit vector in direction of the arrow
  6198.                   XINCH = DX * DINDX
  6199.                   YINCH = DY * DINDY
  6200.                   RINCH = SQRT(XINCH*XINCH + YINCH*YINCH)
  6201.                   CA = XINCH / RINCH
  6202.                   SA = YINCH / RINCH
  6203. C                 -- Semiangle in radians
  6204.                   SEMANG = AHANGL/2.0/57.296
  6205.                   SO = SIN(SEMANG)
  6206.                   CO = -COS(SEMANG)
  6207. C                 -- Vector back along one edge of the arrow
  6208.                   XP = DHX * (CA*CO - SA*SO)
  6209.                   YP = DHY * (SA*CO + CA*SO)
  6210. C                 -- Vector back along other edge of the arrow
  6211.                   XM = DHX * (CA*CO + SA*SO)
  6212.                   YM = DHY * (SA*CO - CA*SO)
  6213. C                 -- Draw the arrowhead
  6214.                   PX(1) = X2
  6215.                   PY(1) = Y2
  6216.                   PX(2) = X2 + XP
  6217.                   PY(2) = Y2 + YP
  6218.                   PX(3) = X2 + 0.5*(XP+XM)*(1.0-AHVENT)
  6219.                   PY(3) = Y2 + 0.5*(YP+YM)*(1.0-AHVENT)
  6220.                   PX(4) = X2 + XM
  6221.                   PY(4) = Y2 + YM
  6222.                   CALL PGPOLY(4, PX, PY)
  6223.                   CALL PGMOVE(PX(3), PY(3))
  6224.               END IF
  6225.           END IF
  6226.       END IF
  6227.       CALL PGDRAW(X1, Y1)
  6228.       CALL PGMOVE(X2,Y2)
  6229.       CALL PGSFS(FS)
  6230.       CALL PGEBUF
  6231.       RETURN
  6232.       END
  6233. C*PGASK -- control new page prompting
  6234. C%void cpgask(Logical flag);
  6235. C+
  6236.       SUBROUTINE PGASK (FLAG)
  6237.       LOGICAL FLAG
  6238. C
  6239. C Change the ``prompt state'' of PGPLOT. If the prompt state is
  6240. C ON, PGPAGE will type ``Type RETURN for next page:'' and will wait
  6241. C for the user to type a carriage-return before starting a new page.
  6242. C The initial prompt state (after a call to PGBEG) is ON for 
  6243. C interactive devices. Prompt state is always OFF for non-interactive 
  6244. C devices.
  6245. C
  6246. C Arguments:
  6247. C  FLAG   (input)  : if .TRUE., and if the device is an interactive
  6248. C                    device, the prompt state will be set to ON. If
  6249. C                    .FALSE., the prompt state will be set to OFF.
  6250. C--
  6251. C-----------------------------------------------------------------------
  6252.       INCLUDE     'f77.PGPLOT/IN'
  6253.       LOGICAL     PGNOTO
  6254.       CHARACTER*1 TYPE
  6255. C
  6256.       IF (PGNOTO('PGASK')) RETURN
  6257. C
  6258.       IF (FLAG) THEN
  6259.           CALL GRQTYP(TYPE,PGPRMP(PGID))
  6260.       ELSE
  6261.           PGPRMP(PGID) = .FALSE.
  6262.       END IF
  6263.       END
  6264. C*PGBAND -- read cursor position, with anchor
  6265. C%int cpgband(int mode, int posn, float xref, float yref, float *x,\
  6266. C%            float *y, char *ch_scalar);
  6267. C+
  6268.       INTEGER FUNCTION PGBAND (MODE, POSN, XREF, YREF, X, Y, CH)
  6269.       INTEGER MODE, POSN
  6270.       REAL XREF, YREF, X, Y
  6271.       CHARACTER*(*) CH
  6272. C
  6273. C Read the cursor position and a character typed by the user.
  6274. C The position is returned in world coordinates.  PGBAND positions
  6275. C the cursor at the position specified (if POSN=1), allows the user to
  6276. C move the cursor using the mouse or arrow keys or whatever is available
  6277. C on the device. When he has positioned the cursor, the user types a
  6278. C single character on the keyboard; PGBAND then returns this
  6279. C character and the new cursor position (in world coordinates).
  6280. C
  6281. C Some interactive devices offer a selection of cursor types,
  6282. C implemented as thin lines that move with the cursor, but without
  6283. C erasing underlying graphics. Of these types, some extend between
  6284. C a stationary anchor-point at XREF,YREF, and the position of the
  6285. C cursor, while others simply follow the cursor without changing shape
  6286. C or size. The cursor type is specified with one of the following MODE
  6287. C values. Cursor types that are not supported by a given device, are
  6288. C treated as MODE=0.
  6289. C
  6290. C -- If MODE=0, the anchor point is ignored and the routine behaves
  6291. C like PGCURS.
  6292. C -- If MODE=1, a straight line is drawn joining the anchor point 
  6293. C and the cursor position.
  6294. C -- If MODE=2, a hollow rectangle is extended as the cursor is moved,
  6295. C with one vertex at the anchor point and the opposite vertex at the
  6296. C current cursor position; the edges of the rectangle are horizontal
  6297. C and vertical.
  6298. C -- If MODE=3, two horizontal lines are extended across the width of
  6299. C the display, one drawn through the anchor point and the other
  6300. C through the moving cursor position. This could be used to select
  6301. C a Y-axis range when one end of the range is known.
  6302. C -- If MODE=4, two vertical lines are extended over the height of
  6303. C the display, one drawn through the anchor point and the other
  6304. C through the moving cursor position. This could be used to select an
  6305. C X-axis range when one end of the range is known.
  6306. C -- If MODE=5, a horizontal line is extended through the cursor
  6307. C position over the width of the display. This could be used to select
  6308. C an X-axis value such as the start of an X-axis range. The anchor point
  6309. C is ignored.
  6310. C -- If MODE=6, a vertical line is extended through the cursor
  6311. C position over the height of the display. This could be used to select
  6312. C a Y-axis value such as the start of a Y-axis range. The anchor point
  6313. C is ignored.
  6314. C -- If MODE=7, a cross-hair, centered on the cursor, is extended over
  6315. C the width and height of the display. The anchor point is ignored.
  6316. C
  6317. C Returns:
  6318. C  PGBAND          : 1 if the call was successful; 0 if the device
  6319. C                    has no cursor or some other error occurs.
  6320. C Arguments:
  6321. C  MODE   (input)  : display mode (0, 1, ..7: see above).
  6322. C  POSN   (input)  : if POSN=1, PGBAND attempts to place the cursor
  6323. C                    at point (X,Y); if POSN=0, it leaves the cursor
  6324. C                    at its current position. (On some devices this
  6325. C                    request may be ignored.)
  6326. C  XREF   (input)  : the world x-coordinate of the anchor point.
  6327. C  YREF   (input)  : the world y-coordinate of the anchor point.
  6328. C  X      (in/out) : the world x-coordinate of the cursor.
  6329. C  Y      (in/out) : the world y-coordinate of the cursor.
  6330. C  CH     (output) : the character typed by the user; if the device has
  6331. C                    no cursor or if some other error occurs, the value
  6332. C                    CHAR(0) [ASCII NUL character] is returned.
  6333. C
  6334. C Note: The cursor coordinates (X,Y) may be changed by PGBAND even if
  6335. C the device has no cursor or if the user does not move the cursor.
  6336. C Under these circumstances, the position returned in (X,Y) is that of
  6337. C the pixel nearest to the requested position.
  6338. C--
  6339. C 7-Sep-1994 - new routine [TJP].
  6340. C-----------------------------------------------------------------------
  6341.       INCLUDE      'f77.PGPLOT/IN'
  6342.       INTEGER      GRCURS, I, J, IREF, JREF
  6343.       LOGICAL      PGNOTO
  6344. C
  6345.       IF (PGNOTO('PGBAND')) THEN
  6346.           CH = CHAR(0)
  6347.           PGBAND = 0
  6348.           RETURN
  6349.       END IF
  6350.       IF (MODE.LT.0 .OR. MODE.GT.7) CALL GRWARN(
  6351.      :     'Invalid MODE argument in PGBAND')
  6352.       IF (POSN.LT.0 .OR. POSN.GT.1) CALL GRWARN(
  6353.      :     'Invalid POSN argument in PGBAND')
  6354. C
  6355.       I = NINT(PGXORG(PGID) + X*PGXSCL(PGID))
  6356.       J = NINT(PGYORG(PGID) + Y*PGYSCL(PGID))
  6357.       IREF = NINT(PGXORG(PGID) + XREF*PGXSCL(PGID))
  6358.       JREF = NINT(PGYORG(PGID) + YREF*PGYSCL(PGID))
  6359.       PGBAND = GRCURS(PGID,I,J,IREF,JREF,MODE,POSN,CH)
  6360.       X = (I - PGXORG(PGID))/PGXSCL(PGID)
  6361.       Y = (J - PGYORG(PGID))/PGYSCL(PGID)
  6362.       CALL GRTERM
  6363.       END
  6364. C*PGBBUF -- begin batch of output (buffer)
  6365. C%void cpgbbuf(void);
  6366. C+
  6367.       SUBROUTINE PGBBUF
  6368. C
  6369. C Begin saving graphical output commands in an internal buffer; the
  6370. C commands are held until a matching PGEBUF call (or until the buffer
  6371. C is emptied by PGUPDT). This can greatly improve the efficiency of
  6372. C PGPLOT.  PGBBUF increments an internal counter, while PGEBUF
  6373. C decrements this counter and flushes the buffer to the output
  6374. C device when the counter drops to zero.  PGBBUF and PGEBUF calls
  6375. C should always be paired.
  6376. C
  6377. C Arguments: none
  6378. C--
  6379. C 21-Nov-1985 - new routine [TJP].
  6380. C-----------------------------------------------------------------------
  6381.       INCLUDE 'f77.PGPLOT/IN'
  6382.       LOGICAL PGNOTO
  6383. C
  6384.       IF (.NOT.PGNOTO('PGBBUF')) THEN
  6385.           PGBLEV(PGID) = PGBLEV(PGID) + 1
  6386.       END IF
  6387.       END
  6388. C*PGBEG -- begin PGPLOT, open output device
  6389. C%int cpgbeg(int unit, const char *file, int nxsub, int nysub);
  6390. C+
  6391.       INTEGER FUNCTION PGBEG (UNIT, FILE, NXSUB, NYSUB)
  6392.       INTEGER       UNIT
  6393.       CHARACTER*(*) FILE
  6394.       INTEGER       NXSUB, NYSUB
  6395. C
  6396. C Begin PGPLOT, open the plot file.  A call to PGBEG is
  6397. C required before any other calls to PGPLOT subroutines.  If a plot
  6398. C file is already open for PGPLOT output, it is closed before the new
  6399. C file is opened.
  6400. C
  6401. C Returns:
  6402. C  PGBEG         : a status return value. A value of 1 indicates
  6403. C                    successful completion, any other value indicates
  6404. C                    an error. In the event of error a message is
  6405. C                    written on the standard error unit.  
  6406. C                    To test the return value, call
  6407. C                    PGBEG as a function, eg IER=PGBEG(...); note
  6408. C                    that PGBEG must be declared INTEGER in the
  6409. C                    calling program.
  6410. C Arguments:
  6411. C  UNIT  (input)   : this argument is ignored by PGBEG (use zero).
  6412. C  FILE  (input)   : the "device specification" for the plot device.
  6413. C                    Device specifications are installation dependent,
  6414. C                    but usually have the form "device/type" or
  6415. C                    "file/type". If this argument is a
  6416. C                    question mark ('?'), PGBEG will prompt the user
  6417. C                    to supply a string. If the argument is a blank
  6418. C                    string (' '), PGBEG will use the value of
  6419. C                    environment variable PGPLOT_DEV.
  6420. C  NXSUB  (input)  : the number of subdivisions of the view surface in
  6421. C                    X (>0 or <0).
  6422. C  NYSUB  (input)  : the number of subdivisions of the view surface in
  6423. C                    Y (>0).
  6424. C                    PGPLOT puts NXSUB x NYSUB graphs on each plot
  6425. C                    page or screen; when the view surface is sub-
  6426. C                    divided in this way, PGPAGE moves to the next
  6427. C                    panel, not the  next physical page. If
  6428. C                    NXSUB > 0, PGPLOT uses the panels in row
  6429. C                    order; if <0, PGPLOT uses them in column order.
  6430. C--
  6431. C 21-Dec-1995 [TJP] - changed for multiple devices; call PGOPEN [TJP].
  6432. C-----------------------------------------------------------------------
  6433.       INTEGER       IER
  6434.       INTEGER       PGOPEN
  6435. C
  6436. C Initialize PGPLOT if necessary.
  6437. C
  6438.       CALL PGINIT
  6439. C
  6440. C Close the plot-file if it is already open.
  6441. C
  6442.       CALL PGEND
  6443. C
  6444. C Call PGOPEN to open the device.
  6445. C
  6446.       IER = PGOPEN(FILE)
  6447.       IF (IER.GT.0) THEN
  6448.          CALL PGSUBP(NXSUB, NYSUB)
  6449.          PGBEG = 1
  6450.       ELSE
  6451.          PGBEG = IER
  6452.       END IF
  6453. C
  6454.       RETURN
  6455.       END
  6456. C*PGBEGIN -- non-standard alias for PGBEG
  6457. C+
  6458.       INTEGER FUNCTION PGBEGIN (UNIT, FILE, NXSUB, NYSUB)
  6459.       INTEGER       UNIT
  6460.       CHARACTER*(*) FILE
  6461.       INTEGER       NXSUB, NYSUB
  6462. C
  6463. C See description of PGBEG.   
  6464. C--
  6465.       INTEGER       PGBEG
  6466.       PGBEGIN = PGBEG (UNIT, FILE, NXSUB, NYSUB)
  6467.       END
  6468. C*PGBIN -- histogram of binned data
  6469. C%void cpgbin(int nbin, const float *x, const float *data, \
  6470. C% Logical center);
  6471. C+
  6472.       SUBROUTINE PGBIN (NBIN, X, DATA, CENTER)
  6473.       INTEGER NBIN
  6474.       REAL X(*), DATA(*)
  6475.       LOGICAL CENTER
  6476. C
  6477. C Plot a histogram of NBIN values with X(1..NBIN) values along
  6478. C the ordinate, and DATA(1...NBIN) along the abscissa. Bin width is
  6479. C spacing between X values.
  6480. C
  6481. C Arguments:
  6482. C  NBIN   (input)  : number of values.
  6483. C  X      (input)  : abscissae of bins.
  6484. C  DATA   (input)  : data values of bins.
  6485. C  CENTER (input)  : if .TRUE., the X values denote the center of the
  6486. C                    bin; if .FALSE., the X values denote the lower
  6487. C                    edge (in X) of the bin.
  6488. C--
  6489. C 19-Aug-92: change argument check (TJP).
  6490. C-----------------------------------------------------------------------
  6491.       LOGICAL  PGNOTO
  6492.       INTEGER  IBIN
  6493.       REAL     TX(4), TY(4)
  6494. C
  6495. C Check arguments.
  6496. C
  6497.       IF (NBIN.LT.2) RETURN
  6498.       IF (PGNOTO('PGBIN')) RETURN
  6499.       CALL PGBBUF
  6500. C
  6501. C Draw Histogram. Centered an uncentered bins are treated separately.
  6502. C
  6503.       IF (CENTER) THEN
  6504. C         !set up initial point.
  6505.           TX(2) = (3.*X(1) - X(2))/2.
  6506.           TY(2) = DATA(1)
  6507.           TX(3) = (X(1) + X(2))/2.
  6508.           TY(3) = TY(2)
  6509.           CALL GRVCT0(2, .FALSE., 2, TX(2), TY(2))
  6510. C         !draw initial horizontal line
  6511. C         !now loop over bins
  6512.           DO 10 IBIN=2,NBIN-1
  6513.               TX(1) = TX(3)
  6514.               TX(2) = TX(1)
  6515.               TX(3) = ( X(IBIN) + X(IBIN+1) ) / 2.
  6516.               TY(1) = TY(3)
  6517.               TY(2) = DATA(IBIN)
  6518.               TY(3) = TY(2)
  6519.               CALL GRVCT0(2, .FALSE., 3, TX, TY)
  6520.    10     CONTINUE
  6521. C         !now draw last segment.
  6522.           TX(1) = TX(3)
  6523.           TX(2) = TX(1)
  6524.           TX(3) = (3.*X(NBIN) - X(NBIN-1) )/2.
  6525.           TY(1) = TY(3)
  6526.           TY(2) = DATA(NBIN)
  6527.           TY(3) = TY(2)
  6528.           CALL GRVCT0(2, .FALSE., 3, TX, TY)
  6529. C
  6530. C               Uncentered bins
  6531. C
  6532.       ELSE
  6533. C         !set up first line.
  6534.           TX(2) = X(1)
  6535.           TY(2) = DATA(1)
  6536.           TX(3) = X(2)
  6537.           TY(3) = TY(2)
  6538.           CALL GRVCT0(2, .FALSE., 2, TX(2), TY(2))
  6539.           DO 20 IBIN=2,NBIN
  6540.               TX(1) = TX(3)
  6541.               TX(2) = TX(1)
  6542.               IF (IBIN.EQ.NBIN) THEN
  6543.                   TX(3) = 2.*X(NBIN) - X(NBIN-1)
  6544.               ELSE
  6545.                   TX(3) = X(IBIN+1)
  6546.               END IF
  6547.               TY(1) = TY(3)
  6548. C             !get height for last segment.
  6549.               TY(2) = DATA(IBIN)
  6550.               TY(3) = TY(2)
  6551.               CALL GRVCT0(2, .FALSE., 3, TX, TY)
  6552.    20     CONTINUE
  6553.       END IF
  6554. C
  6555.       CALL PGEBUF
  6556.       END
  6557. C*PGBOX -- draw labeled frame around viewport
  6558. C%void cpgbox(const char *xopt, float xtick, int nxsub, \
  6559. C% const char *yopt, float ytick, int nysub);
  6560. C+
  6561.       SUBROUTINE PGBOX (XOPT, XTICK, NXSUB, YOPT, YTICK, NYSUB)
  6562.       CHARACTER*(*) XOPT, YOPT
  6563.       REAL XTICK, YTICK
  6564.       INTEGER NXSUB, NYSUB
  6565. C
  6566. C Annotate the viewport with frame, axes, numeric labels, etc.
  6567. C PGBOX is called by on the user's behalf by PGENV, but may also be
  6568. C called explicitly.
  6569. C
  6570. C Arguments:
  6571. C  XOPT   (input)  : string of options for X (horizontal) axis of
  6572. C                    plot. Options are single letters, and may be in
  6573. C                    any order (see below).
  6574. C  XTICK  (input)  : world coordinate interval between major tick marks
  6575. C                    on X axis. If XTICK=0.0, the interval is chosen by
  6576. C                    PGBOX, so that there will be at least 3 major tick
  6577. C                    marks along the axis.
  6578. C  NXSUB  (input)  : the number of subintervals to divide the major
  6579. C                    coordinate interval into. If XTICK=0.0 or NXSUB=0,
  6580. C                    the number is chosen by PGBOX.
  6581. C  YOPT   (input)  : string of options for Y (vertical) axis of plot.
  6582. C                    Coding is the same as for XOPT.
  6583. C  YTICK  (input)  : like XTICK for the Y axis.
  6584. C  NYSUB  (input)  : like NXSUB for the Y axis.
  6585. C
  6586. C Options (for parameters XOPT and YOPT):
  6587. C  A : draw Axis (X axis is horizontal line Y=0, Y axis is vertical
  6588. C      line X=0).
  6589. C  B : draw bottom (X) or left (Y) edge of frame.
  6590. C  C : draw top (X) or right (Y) edge of frame.
  6591. C  G : draw Grid of vertical (X) or horizontal (Y) lines.
  6592. C  I : Invert the tick marks; ie draw them outside the viewport
  6593. C      instead of inside.
  6594. C  L : label axis Logarithmically (see below).
  6595. C  N : write Numeric labels in the conventional location below the
  6596. C      viewport (X) or to the left of the viewport (Y).
  6597. C  P : extend ("Project") major tick marks outside the box (ignored if
  6598. C      option I is specified).
  6599. C  M : write numeric labels in the unconventional location above the
  6600. C      viewport (X) or to the right of the viewport (Y).
  6601. C  T : draw major Tick marks at the major coordinate interval.
  6602. C  S : draw minor tick marks (Subticks).
  6603. C  V : orient numeric labels Vertically. This is only applicable to Y.
  6604. C      The default is to write Y-labels parallel to the axis.
  6605. C  1 : force decimal labelling, instead of automatic choice (see PGNUMB).
  6606. C  2 : force exponential labelling, instead of automatic.
  6607. C
  6608. C To get a complete frame, specify BC in both XOPT and YOPT.
  6609. C Tick marks, if requested, are drawn on the axes or frame
  6610. C or both, depending which are requested. If none of ABC is specified,
  6611. C tick marks will not be drawn. When PGENV calls PGBOX, it sets both
  6612. C XOPT and YOPT according to the value of its parameter AXIS:
  6613. C -1: 'BC', 0: 'BCNST', 1: 'ABCNST', 2: 'ABCGNST'.
  6614. C
  6615. C For a logarithmic axis, the major tick interval is always 1.0. The
  6616. C numeric label is 10**(x) where x is the world coordinate at the
  6617. C tick mark. If subticks are requested, 8 subticks are drawn between
  6618. C each major tick at equal logarithmic intervals.
  6619. C
  6620. C To label an axis with time (days, hours, minutes, seconds) or
  6621. C angle (degrees, arcmin, arcsec), use routine PGTBOX.
  6622. C--
  6623. C 19-Oct-1983
  6624. C 23-Sep-1984 - fix bug in labelling reversed logarithmic axes.
  6625. C  6-May-1985 - improve behavior for pen plotters [TJP].
  6626. C 23-Nov-1985 - add 'P' option [TJP].
  6627. C 14-Jan-1986 - use new routine PGBOX1 to fix problem of missing
  6628. C               labels at end of axis [TJP].
  6629. C  8-Apr-1987 - improve automatic choice of tick interval; improve
  6630. C               erroneous rounding of tick interval to 1 digit [TJP].
  6631. C 23-Apr-1987 - fix bug: limit max number of ticks to ~10 [TJP].
  6632. C  7-Nov-1987 - yet another change to algorithm for choosing tick
  6633. C               interval; maximum tick interval is now 0.2*range of
  6634. C               axis, which may round up to 0.5 [TJP].
  6635. C 15-Dec-1988 - correct declaration of MAJOR [TJP].
  6636. C  6-Sep-1989 - use Fortran generic intrinsic functions [TJP].
  6637. C 18-Oct-1990 - correctly initialize UTAB(1) [AFT].
  6638. C 19-Oct-1990 - do all plotting in world coordinates [TJP].
  6639. C  6-Nov-1991 - label logarithmic subticks when necessary [TJP].
  6640. C  4-Jul-1994 - add '1' and '2' options [TJP].
  6641. C 20-Apr-1995 - adjust position of labels slightly, and move out
  6642. C               when ticks are inverted [TJP].
  6643. C-----------------------------------------------------------------------
  6644.       INCLUDE  'f77.PGPLOT/IN'
  6645.       CHARACTER*20  CLBL
  6646.       CHARACTER*64  OPT
  6647.       LOGICAL  XOPTA, XOPTB, XOPTC, XOPTG, XOPTN, XOPTM, XOPTT, XOPTS
  6648.       LOGICAL  YOPTA, YOPTB, YOPTC, YOPTG, YOPTN, YOPTM, YOPTT, YOPTS
  6649.       LOGICAL  XOPTI, YOPTI, YOPTV, XOPTL, YOPTL, XOPTP, YOPTP, RANGE
  6650.       LOGICAL  IRANGE, MAJOR, XOPTLS, YOPTLS, PGNOTO
  6651.       REAL     TAB(9), UTAB(9)
  6652.       INTEGER  I, I1, I2, J, NC, NP, NV, KI
  6653.       INTEGER  NSUBX, NSUBY, JMAX, XNFORM, YNFORM
  6654.       REAL     TIKL, TIKL1, TIKL2, XC, YC
  6655.       REAL     XINT, XINT2, XVAL, YINT, YINT2, YVAL
  6656.       REAL     PGRND
  6657.       REAL     A, B, C
  6658.       REAL     XNDSP, XMDSP, YNDSP, YMDSP, YNVDSP, YMVDSP
  6659.       REAL     XBLC, XTRC, YBLC, YTRC
  6660.       INTRINSIC ABS, INDEX, INT, LOG10, MAX, MIN, MOD, NINT, SIGN, REAL
  6661. C
  6662. C Table of logarithms 1..9
  6663. C
  6664.       DATA TAB / 0.00000, 0.30103, 0.47712, 0.60206, 0.69897,
  6665.      1           0.77815, 0.84510, 0.90309, 0.95424 /
  6666. C
  6667.       RANGE(A,B,C) = (A.LT.B.AND.B.LT.C) .OR. (C.LT.B.AND.B.LT.A)
  6668.       IRANGE(A,B,C) = (A.LE.B.AND.B.LE.C) .OR. (C.LE.B.AND.B.LE.A)
  6669. C
  6670.       IF (PGNOTO('PGBOX')) RETURN
  6671.       CALL PGBBUF
  6672.       CALL PGQWIN(XBLC, XTRC, YBLC, YTRC)
  6673. C
  6674. C Decode options.
  6675. C
  6676.       CALL GRTOUP(OPT,XOPT)
  6677.       XOPTA = INDEX(OPT,'A').NE.0 .AND. RANGE(YBLC,0.0,YTRC)
  6678.       XOPTB = INDEX(OPT,'B').NE.0
  6679.       XOPTC = INDEX(OPT,'C').NE.0
  6680.       XOPTG = INDEX(OPT,'G').NE.0
  6681.       XOPTI = INDEX(OPT,'I').NE.0
  6682.       XOPTL = INDEX(OPT,'L').NE.0
  6683.       XOPTM = INDEX(OPT,'M').NE.0
  6684.       XOPTN = INDEX(OPT,'N').NE.0
  6685.       XOPTS = INDEX(OPT,'S').NE.0
  6686.       XOPTT = INDEX(OPT,'T').NE.0
  6687.       XOPTP = INDEX(OPT,'P').NE.0 .AND. (.NOT.XOPTI)
  6688.       XNFORM = 0
  6689.       IF (INDEX(OPT,'1').NE.0) XNFORM = 1
  6690.       IF (INDEX(OPT,'2').NE.0) XNFORM = 2
  6691.       CALL GRTOUP(OPT,YOPT)
  6692.       YOPTA = INDEX(OPT,'A').NE.0 .AND. RANGE(XBLC,0.0,XTRC)
  6693.       YOPTB = INDEX(OPT,'B').NE.0
  6694.       YOPTC = INDEX(OPT,'C').NE.0
  6695.       YOPTG = INDEX(OPT,'G').NE.0
  6696.       YOPTI = INDEX(OPT,'I').NE.0
  6697.       YOPTL = INDEX(OPT,'L').NE.0
  6698.       YOPTN = INDEX(OPT,'N').NE.0
  6699.       YOPTM = INDEX(OPT,'M').NE.0
  6700.       YOPTS = INDEX(OPT,'S').NE.0
  6701.       YOPTT = INDEX(OPT,'T').NE.0
  6702.       YOPTV = INDEX(OPT,'V').NE.0
  6703.       YOPTP = INDEX(OPT,'P').NE.0 .AND. (.NOT.YOPTI)
  6704.       YNFORM = 0
  6705.       IF (INDEX(OPT,'1').NE.0) YNFORM = 1
  6706.       IF (INDEX(OPT,'2').NE.0) YNFORM = 2
  6707. C
  6708. C Displacement of labels from edge of box
  6709. C (for X bottom/top, Y left/right, and Y left/right with V option).
  6710. C
  6711.       XNDSP = 1.2
  6712.       XMDSP = 0.7
  6713.       YNDSP = 0.7
  6714.       YMDSP = 1.2
  6715.       YNVDSP = 0.7
  6716.       YMVDSP = 0.7
  6717.       IF (XOPTI) THEN
  6718.          XNDSP = XNDSP + 0.3
  6719.          XMDSP = XMDSP + 0.3
  6720.       END IF
  6721.       IF (YOPTI) THEN
  6722.          YNDSP = YNDSP + 0.3
  6723.          YMDSP = YMDSP + 0.3
  6724.          YNVDSP = YNVDSP + 0.3
  6725.          YMVDSP = YMVDSP + 0.3
  6726.       END IF
  6727. C
  6728. C Remove window.
  6729. C
  6730.       CALL GRAREA(PGID,0.,0.,-1.,-1.)
  6731. C
  6732. C Draw box.
  6733. C
  6734.       IF (XOPTB) THEN
  6735.           CALL GRMOVA(XBLC, YBLC)
  6736.           CALL GRLINA(XTRC, YBLC)
  6737.       END IF
  6738.       IF (YOPTC) THEN
  6739.           CALL GRMOVA(XTRC, YBLC)
  6740.           CALL GRLINA(XTRC, YTRC)
  6741.       END IF
  6742.       IF (XOPTC) THEN
  6743.           CALL GRMOVA(XTRC, YTRC)
  6744.           CALL GRLINA(XBLC, YTRC)
  6745.       END IF
  6746.       IF (YOPTB) THEN
  6747.           CALL GRMOVA(XBLC, YTRC)
  6748.           CALL GRLINA(XBLC, YBLC)
  6749.       END IF
  6750. C
  6751. C Draw axes if required.
  6752. C
  6753.       IF (XOPTA.AND..NOT.XOPTG) THEN
  6754.           CALL GRMOVA(XBLC, 0.0)
  6755.           CALL GRLINA(XTRC, 0.0)
  6756.       END IF
  6757.       IF (YOPTA.AND..NOT.YOPTG) THEN
  6758.           CALL GRMOVA(0.0, YBLC)
  6759.           CALL GRLINA(0.0, YTRC)
  6760.       END IF
  6761. C
  6762. C Length of X tick marks.
  6763. C
  6764.       TIKL1 = PGXSP(PGID)*0.6*(YTRC-YBLC)/PGYLEN(PGID)
  6765.       IF (XOPTI) TIKL1 = -TIKL1
  6766.       TIKL2 = TIKL1*0.5
  6767. C
  6768. C Choose X tick intervals. Major interval = XINT,
  6769. C minor interval = XINT2 = XINT/NSUBX.
  6770. C
  6771.       UTAB(1) = 0.0
  6772.       IF (XOPTL) THEN
  6773.           XINT = SIGN(1.0,XTRC-XBLC)
  6774.           NSUBX = 1
  6775.           DO 10 J=2,9
  6776.               UTAB(J) = TAB(J)
  6777.               IF (XINT.LT.0.0) UTAB(J) = 1.0-TAB(J)
  6778.    10     CONTINUE
  6779.       ELSE IF (XTICK.EQ.0.0) THEN
  6780.           XINT = MAX(0.05, MIN(7.0*PGXSP(PGID)/PGXLEN(PGID), 0.20))
  6781.      1           *(XTRC-XBLC)
  6782.           XINT = PGRND(XINT,NSUBX)
  6783.       ELSE
  6784.           XINT = SIGN(XTICK,XTRC-XBLC)
  6785.           NSUBX = MAX(NXSUB,1)
  6786.       END IF
  6787.       IF (.NOT.XOPTS) NSUBX = 1
  6788.       NP = INT(LOG10(ABS(XINT)))-4
  6789.       NV = NINT(XINT/10.**NP)
  6790.       XINT2 = XINT/NSUBX
  6791.       XOPTLS = XOPTL .AND. XOPTS .AND. (ABS(XTRC-XBLC).LT.2.0)
  6792. C
  6793. C Draw X grid.
  6794. C
  6795.       IF (XOPTG) THEN
  6796.           CALL PGBOX1(XBLC, XTRC, XINT, I1, I2)
  6797.           DO 20 I=I1,I2
  6798.               CALL GRMOVA(REAL(I)*XINT, YBLC)
  6799.               CALL GRLINA(REAL(I)*XINT, YTRC)
  6800.    20     CONTINUE
  6801.       END IF
  6802. C
  6803. C Draw X ticks.
  6804. C
  6805.       IF (XOPTT.OR.XOPTS) THEN
  6806.           CALL PGBOX1(XBLC, XTRC, XINT2, I1, I2)
  6807.           JMAX = 1
  6808.           IF (XOPTL.AND.XOPTS) JMAX=9
  6809. C
  6810. C         Bottom ticks.
  6811. C
  6812.           IF (XOPTB) THEN
  6813.             DO 40 I=I1-1,I2
  6814.             DO 30 J=1,JMAX
  6815.                 MAJOR = (MOD(I,NSUBX).EQ.0).AND.XOPTT.AND.J.EQ.1
  6816.                 TIKL = TIKL2
  6817.                 IF (MAJOR) TIKL = TIKL1
  6818.                 XVAL = (I+UTAB(J))*XINT2
  6819.                 IF (IRANGE(XBLC,XVAL,XTRC)) THEN
  6820.                     IF (XOPTP.AND.MAJOR) THEN
  6821.                         CALL GRMOVA(XVAL, YBLC-TIKL2)
  6822.                     ELSE
  6823.                         CALL GRMOVA(XVAL, YBLC)
  6824.                     END IF
  6825.                     CALL GRLINA(XVAL, YBLC+TIKL)
  6826.                 END IF
  6827.    30        CONTINUE
  6828.    40       CONTINUE
  6829.           END IF
  6830. C
  6831. C         Axis ticks.
  6832. C
  6833.           IF (XOPTA) THEN
  6834.             DO 60 I=I1-1,I2
  6835.             DO 50 J=1,JMAX
  6836.                 MAJOR = (MOD(I,NSUBX).EQ.0).AND.XOPTT.AND.J.EQ.1
  6837.                 TIKL = TIKL2
  6838.                 IF (MAJOR) TIKL = TIKL1
  6839.                 XVAL = (I+UTAB(J))*XINT2
  6840.                 IF (IRANGE(XBLC,XVAL,XTRC)) THEN
  6841.                     CALL GRMOVA(XVAL, -TIKL)
  6842.                     CALL GRLINA(XVAL, TIKL)
  6843.                 END IF
  6844.    50       CONTINUE
  6845.    60       CONTINUE
  6846.           END IF
  6847. C
  6848. C         Top ticks.
  6849. C
  6850.           IF (XOPTC) THEN
  6851.             DO 80 I=I1-1,I2
  6852.             DO 70 J=1,JMAX
  6853.                 MAJOR = (MOD(I,NSUBX).EQ.0).AND.XOPTT.AND.J.EQ.1
  6854.                 TIKL = TIKL2
  6855.                 IF (MAJOR) TIKL = TIKL1
  6856.                 XVAL = (I+UTAB(J))*XINT2
  6857.                 IF (IRANGE(XBLC,XVAL,XTRC)) THEN
  6858.                     CALL GRMOVA(XVAL, YTRC-TIKL)
  6859.                     CALL GRLINA(XVAL, YTRC)
  6860.                 END IF
  6861.    70       CONTINUE
  6862.    80       CONTINUE
  6863.           END IF
  6864.       END IF
  6865. C
  6866. C Write X labels.
  6867. C
  6868.       IF (XOPTN .OR. XOPTM) THEN
  6869.           CALL PGBOX1(XBLC, XTRC, XINT, I1, I2)
  6870.           DO 90 I=I1,I2
  6871.               XC = (I*XINT-XBLC)/(XTRC-XBLC)
  6872.               IF (XOPTL) THEN
  6873.                   CALL PGNUMB(1,NINT(I*XINT),XNFORM,CLBL,NC)
  6874.               ELSE
  6875.                   CALL PGNUMB(I*NV,NP,XNFORM,CLBL,NC)
  6876.               END IF
  6877.               IF (XOPTN) CALL PGMTXT('B', XNDSP, XC, 0.5, CLBL(1:NC))
  6878.               IF (XOPTM) CALL PGMTXT('T', XMDSP, XC, 0.5, CLBL(1:NC))
  6879.    90     CONTINUE
  6880.       END IF
  6881. C
  6882. C Extra X labels for log axes.
  6883. C
  6884.       IF (XOPTLS) THEN
  6885.           CALL PGBOX1(XBLC, XTRC, XINT2, I1, I2)
  6886.           DO 401 I=I1-1,I2
  6887.              DO 301 J=2,5,3
  6888.                 XVAL = (I+UTAB(J))*XINT2
  6889.                 XC = (XVAL-XBLC)/(XTRC-XBLC)
  6890.                 KI = I
  6891.                 IF (XTRC.LT.XBLC) KI = KI+1
  6892.                 IF (IRANGE(XBLC,XVAL,XTRC)) THEN
  6893.                     CALL PGNUMB(J,NINT(KI*XINT2),XNFORM,CLBL,NC)
  6894.                     IF (XOPTN) 
  6895.      1                CALL PGMTXT('B', XNDSP, XC, 0.5, CLBL(1:NC))
  6896.                     IF (XOPTM) 
  6897.      1                CALL PGMTXT('T', XMDSP, XC, 0.5, CLBL(1:NC))
  6898.                 END IF
  6899.   301       CONTINUE
  6900.   401     CONTINUE
  6901.       END IF
  6902. C
  6903. C Length of Y tick marks.
  6904. C
  6905.       TIKL1 = PGXSP(PGID)*0.6*(XTRC-XBLC)/PGXLEN(PGID)
  6906.       IF (YOPTI) TIKL1 = -TIKL1
  6907.       TIKL2 = TIKL1*0.5
  6908. C
  6909. C Choose Y tick intervals. Major interval = YINT,
  6910. C minor interval = YINT2 = YINT/NSUBY.
  6911. C
  6912.       UTAB(1) = 0.0
  6913.       IF (YOPTL) THEN
  6914.           YINT = SIGN(1.0,YTRC-YBLC)
  6915.           NSUBY = 1
  6916.           DO 100 J=2,9
  6917.               UTAB(J) = TAB(J)
  6918.               IF (YINT.LT.0.0) UTAB(J) = 1.0-TAB(J)
  6919.   100     CONTINUE
  6920.       ELSE IF (YTICK.EQ.0.0) THEN
  6921.           YINT = MAX(0.05, MIN(7.0*PGXSP(PGID)/PGYLEN(PGID), 0.20))
  6922.      1           *(YTRC-YBLC)
  6923.           YINT = PGRND(YINT,NSUBY)
  6924.       ELSE
  6925.           YINT  = SIGN(YTICK,YTRC-YBLC)
  6926.           NSUBY = MAX(NYSUB,1)
  6927.       END IF
  6928.       IF (.NOT.YOPTS) NSUBY = 1
  6929.       NP = INT(LOG10(ABS(YINT)))-4
  6930.       NV = NINT(YINT/10.**NP)
  6931.       YINT2 = YINT/NSUBY
  6932.       YOPTLS = YOPTL .AND. YOPTS .AND. (ABS(YTRC-YBLC).LT.2.0)
  6933. C
  6934. C Draw Y grid.
  6935. C
  6936.       IF (YOPTG) THEN
  6937.           CALL PGBOX1(YBLC, YTRC, YINT, I1, I2)
  6938.           DO 110 I=I1,I2
  6939.               CALL GRMOVA(XBLC, REAL(I)*YINT)
  6940.               CALL GRLINA(XTRC, REAL(I)*YINT)
  6941.   110     CONTINUE
  6942.       END IF
  6943. C
  6944. C Draw Y ticks.
  6945. C
  6946.       IF (YOPTT.OR.YOPTS) THEN
  6947.           CALL PGBOX1(YBLC, YTRC, YINT2, I1, I2)
  6948.           JMAX = 1
  6949.           IF (YOPTL.AND.YOPTS) JMAX = 9
  6950. C
  6951. C               Left ticks.
  6952. C
  6953.             IF (YOPTB) THEN
  6954.             DO 130 I=I1-1,I2
  6955.             DO 120 J=1,JMAX
  6956.                 MAJOR = (MOD(I,NSUBY).EQ.0).AND.YOPTT.AND.J.EQ.1
  6957.                 TIKL = TIKL2
  6958.                 IF (MAJOR) TIKL = TIKL1
  6959.                 YVAL = (I+UTAB(J))*YINT2
  6960.                 IF (IRANGE(YBLC,YVAL,YTRC)) THEN
  6961.                     IF (YOPTP.AND.MAJOR) THEN
  6962.                         CALL GRMOVA(XBLC-TIKL2, YVAL)
  6963.                     ELSE
  6964.                         CALL GRMOVA(XBLC, YVAL)
  6965.                     END IF
  6966.                     CALL GRLINA(XBLC+TIKL, YVAL)
  6967.                 END IF
  6968.   120       CONTINUE
  6969.   130       CONTINUE
  6970.             END IF
  6971. C
  6972. C               Axis ticks.
  6973. C
  6974.             IF (YOPTA) THEN
  6975.             DO 150 I=I1-1,I2
  6976.             DO 140 J=1,JMAX
  6977.                 MAJOR = (MOD(I,NSUBY).EQ.0).AND.YOPTT.AND.J.EQ.1
  6978.                 TIKL = TIKL2
  6979.                 IF (MAJOR) TIKL = TIKL1
  6980.                 YVAL = (I+UTAB(J))*YINT2
  6981.                 IF (IRANGE(YBLC,YVAL,YTRC)) THEN
  6982.                     CALL GRMOVA(-TIKL, YVAL)
  6983.                     CALL GRLINA(TIKL, YVAL)
  6984.                 END IF
  6985.   140       CONTINUE
  6986.   150       CONTINUE
  6987.             END IF
  6988. C
  6989. C               Right ticks.
  6990. C
  6991.             IF (YOPTC) THEN
  6992.             DO 170 I=I1-1,I2
  6993.             DO 160 J=1,JMAX
  6994.                 MAJOR = (MOD(I,NSUBY).EQ.0).AND.YOPTT.AND.J.EQ.1
  6995.                 TIKL = TIKL2
  6996.                 IF (MAJOR) TIKL = TIKL1
  6997.                 YVAL = (I+UTAB(J))*YINT2
  6998.                 IF (IRANGE(YBLC,YVAL,YTRC)) THEN
  6999.                     CALL GRMOVA(XTRC-TIKL, YVAL)
  7000.                     CALL GRLINA(XTRC, YVAL)
  7001.                 END IF
  7002.   160       CONTINUE
  7003.   170       CONTINUE
  7004.             END IF
  7005.         END IF
  7006. C
  7007. C Write Y labels.
  7008. C
  7009.       IF (YOPTN.OR.YOPTM) THEN
  7010.           CALL PGBOX1(YBLC, YTRC, YINT, I1, I2)
  7011.           DO 180 I=I1,I2
  7012.               YC = (I*YINT-YBLC)/(YTRC-YBLC)
  7013.               IF (YOPTL) THEN
  7014.                   CALL PGNUMB(1,NINT(I*YINT),YNFORM,CLBL,NC)
  7015.               ELSE
  7016.                   CALL PGNUMB(I*NV,NP,YNFORM,CLBL,NC)
  7017.               END IF
  7018.               IF (YOPTV) THEN
  7019.                   IF (YOPTN) CALL PGMTXT('LV',YNVDSP,YC,1.0,CLBL(1:NC))
  7020.                   IF (YOPTM) CALL PGMTXT('RV',YMVDSP,YC,0.0,CLBL(1:NC))
  7021.               ELSE
  7022.                   IF (YOPTN) CALL PGMTXT('L',YNDSP,YC,0.5,CLBL(1:NC))
  7023.                   IF (YOPTM) CALL PGMTXT('R',YMDSP,YC,0.5,CLBL(1:NC))
  7024.               END IF
  7025.   180     CONTINUE
  7026.       END IF
  7027. C
  7028. C Extra Y labels for log axes.
  7029. C
  7030.       IF (YOPTLS) THEN
  7031.           CALL PGBOX1(YBLC, YTRC, YINT2, I1, I2)
  7032.           DO 402 I=I1-1,I2
  7033.             DO 302 J=2,5,3
  7034.                 YVAL = (I+UTAB(J))*YINT2
  7035.                 YC = (YVAL-YBLC)/(YTRC-YBLC)
  7036.                 KI = I
  7037.                 IF (YBLC.GT.YTRC) KI = KI+1
  7038.                 IF (IRANGE(YBLC,YVAL,YTRC)) THEN
  7039.                     CALL PGNUMB(J,NINT(KI*YINT2),YNFORM,CLBL,NC)
  7040.                     IF (YOPTV) THEN
  7041.                     IF (YOPTN) 
  7042.      1                CALL PGMTXT('LV', YNVDSP, YC, 1.0, CLBL(1:NC))
  7043.                     IF (YOPTM) 
  7044.      1                CALL PGMTXT('RV', YMVDSP, YC, 0.0, CLBL(1:NC))
  7045.                     ELSE
  7046.                     IF (YOPTN) 
  7047.      1                CALL PGMTXT('L', YNDSP, YC, 0.5, CLBL(1:NC))
  7048.                     IF (YOPTM) 
  7049.      1                CALL PGMTXT('R', YMDSP, YC, 0.5, CLBL(1:NC))
  7050.                     END IF
  7051.                 END IF
  7052.   302       CONTINUE
  7053.   402     CONTINUE
  7054.       END IF
  7055. C
  7056. C Restore window: interior of box.
  7057. C
  7058.       CALL GRAREA(PGID,PGXOFF(PGID),PGYOFF(PGID),
  7059.      1            PGXLEN(PGID),PGYLEN(PGID))
  7060. C
  7061.       CALL PGEBUF
  7062.       END
  7063. C PGBOX1 -- support routine for PGBOX
  7064. C
  7065.       SUBROUTINE PGBOX1 (XA, XB, XD, I1, I2)
  7066.       REAL XA, XB, XD
  7067.       INTEGER I1, I2
  7068. C
  7069. C This routine is used to determine where to draw the tick marks on
  7070. C an axis. The input arguments XA and XB are the world-coordinate
  7071. C end points of the axis; XD is the tick interval. PGBOX1 returns
  7072. C two integers, I1 and I2, such that the required tick marks are
  7073. C to be placed at world-coordinates (I*XD), for I=I1,...,I2.
  7074. C Normally I2 is greater than or equal to I1, but if there are no
  7075. C values of I such that I*XD lies in the inclusive range (XA, XB),
  7076. C then I2 will be 1 less than I1.
  7077. C
  7078. C Arguments:
  7079. C  XA, XB (input)  : world-coordinate end points of the axis. XA must
  7080. C                    not be equal to XB; otherwise, there are no
  7081. C                    restrictions.
  7082. C  XD     (input)  : world-coordinate tick interval. XD may be positive
  7083. C                    or negative, but may not be zero.
  7084. C  I1, I2 (output) : tick marks should be drawn at world
  7085. C                    coordinates I*XD for I in the inclusive range
  7086. C                    I1...I2 (see above).
  7087. C
  7088. C 14-Jan-1986 - new routine [TJP].
  7089. C 13-Dec-1990 - remove rror check [TJP].
  7090. C-----------------------------------------------------------------------
  7091.       REAL XLO, XHI
  7092. C
  7093.       XLO = MIN(XA/XD, XB/XD)
  7094.       XHI = MAX(XA/XD, XB/XD)
  7095.       I1 = NINT(XLO)
  7096.       IF (I1.LT.XLO) I1 = I1+1
  7097.       I2 = NINT(XHI)
  7098.       IF (I2.GT.XHI) I2 = I2-1
  7099.       END
  7100. C*PGCIRC -- draw a filled or outline circle
  7101. C%void cpgcirc(float xcent, float ycent, float radius);
  7102. C+
  7103.       SUBROUTINE PGCIRC (XCENT, YCENT, RADIUS)
  7104.       REAL XCENT, YCENT, RADIUS
  7105. C
  7106. C Draw a circle. The action of this routine depends
  7107. C on the setting of the Fill-Area Style attribute. If Fill-Area Style
  7108. C is SOLID (the default), the interior of the circle is solid-filled
  7109. C using the current Color Index. If Fill-Area Style is HOLLOW, the
  7110. C outline of the circle is drawn using the current line attributes
  7111. C (color index, line-style, and line-width).
  7112. C
  7113. C Arguments:
  7114. C  XCENT  (input)  : world x-coordinate of the center of the circle.
  7115. C  YCENT  (input)  : world y-coordinate of the center of the circle.
  7116. C  RADIUS (input)  : radius of circle (world coordinates).
  7117. C--
  7118. C 26-Nov-1992 - [TJP].
  7119. C 20-Sep-1994 - adjust number of points according to size [TJP].
  7120. C-----------------------------------------------------------------------
  7121.       INCLUDE 'f77.PGPLOT/IN'
  7122.       INTEGER MAXPTS
  7123.       PARAMETER (MAXPTS=72)
  7124. C
  7125.       INTEGER NPTS,I,RADPIX
  7126.       REAL ANGLE
  7127.       REAL X(MAXPTS),Y(MAXPTS)
  7128. C
  7129.       RADPIX = NINT(RADIUS*MAX(PGXSCL(PGID), PGYSCL(PGID)))
  7130.       NPTS = MAX(8, MIN(MAXPTS, RADPIX))
  7131.       DO 10 I=1,NPTS
  7132.          ANGLE = I*360.0/REAL(NPTS)/57.3
  7133.          X(I) = XCENT + RADIUS*COS(ANGLE)
  7134.          Y(I) = YCENT + RADIUS*SIN(ANGLE)
  7135.    10 CONTINUE
  7136.       CALL PGPOLY (NPTS,X,Y)
  7137. C     write (*,*) 'PGCIRC', NPTS
  7138. C-----------------------------------------------------------------------
  7139.       END
  7140. C
  7141.       SUBROUTINE PGCL (K, X, Y, Z)
  7142.       INTEGER K
  7143.       REAL X, Y, Z
  7144. C
  7145. C PGPLOT (internal routine): Label one contour segment (for use by
  7146. C PGCONX).
  7147. C
  7148. C Arguments:
  7149. C
  7150. C K (input, integer): if K=0, move the pen to (X,Y); if K=1, draw
  7151. C       a line from the current position to (X,Y); otherwise
  7152. C       do nothing.
  7153. C X (input, real): X world-coordinate of end point.
  7154. C Y (input, real): Y world-coordinate of end point.
  7155. C Z (input, real): the value of the contour level, not used by PGCL.
  7156. C--
  7157. C  5-May-1994 - new routine [TJP]
  7158. C  7-Mar-1995 - correct error in angle; do not draw labels outside
  7159. C               window [TJP].
  7160. C 28-Aug-1995 - check arguments of atan2 [TJP].
  7161. C-----------------------------------------------------------------------
  7162.       INCLUDE  'f77.PGPLOT/IN'
  7163.       REAL     XX, YY, XC, YC, XV1, XV2, YV1, YV2, XL, XR, YB, YT
  7164.       REAL     XN, YN
  7165.       REAL     ANGLE, XO, YO, XP, YP, DINDX, DINDY, XBOX(4), YBOX(4)
  7166.       INTEGER  I, TB
  7167.       SAVE     I
  7168.       DATA     I /0/
  7169. C
  7170. C     -- transform to world coordinates
  7171.       XX = TRANS(1) + TRANS(2)*X + TRANS(3)*Y
  7172.       YY = TRANS(4) + TRANS(5)*X + TRANS(6)*Y
  7173. C
  7174.       IF (K.EQ.0) THEN
  7175. C        -- start of contour: reset segment counter
  7176.          I = 0
  7177.       ELSE
  7178. C        -- increment segment counter and check whether this
  7179. C           segment should be labelled
  7180.          I = MOD(I+1,PGCINT)
  7181.          IF (I.EQ.PGCMIN) THEN
  7182. C           -- find center of this segment (XC, YC)
  7183.             CALL PGQPOS(XP, YP)
  7184.             XC = (XX+XP)*0.5
  7185.             YC = (YY+YP)*0.5
  7186. C            -- find slope of this segment (ANGLE)
  7187.             CALL PGQVP(1, XV1, XV2, YV1, YV2)
  7188.             CALL PGQWIN(XL, XR, YB, YT)
  7189.             ANGLE = 0.0
  7190.             IF (XR.NE.XL .AND. YT.NE.YB) THEN
  7191.                DINDX = (XV2 - XV1) / (XR - XL)
  7192.                DINDY = (YV2 - YV1) / (YT - YB)
  7193.                IF (YY-YP.NE.0.0 .OR. XX-XP.NE.0.0)
  7194.      :           ANGLE = 57.3*ATAN2((YY-YP)*DINDY, (XX-XP)*DINDX)
  7195.             END IF
  7196. C           -- check whether point is in window
  7197.             XN = (XC-XL)/(XR-XL)
  7198.             YN = (YC-YB)/(YT-YB)
  7199.             IF (XN.GE.0.0 .AND. XN.LE.1.0 .AND.
  7200.      :          YN.GE.0.0 .AND. YN.LE.1.0) THEN
  7201. C              -- save current text background and set to erase
  7202.                CALL PGQTBG(TB)
  7203.                CALL PGSTBG(0)
  7204. C              -- find bounding box of label
  7205.                CALL PGQTXT(XC, YC, ANGLE, 0.5, PGCLAB, XBOX, YBOX)
  7206.                XO = 0.5*(XBOX(1)+XBOX(3))
  7207.                YO = 0.5*(YBOX(1)+YBOX(3))
  7208. C              -- plot label with bounding box centered at (XC, YC)
  7209.                CALL PGPTXT(2.0*XC-XO, 2.0*YC-YO, ANGLE, 0.5, PGCLAB)
  7210. C              -- restore text background
  7211.                CALL PGSTBG(TB)
  7212.             END IF
  7213.          END IF
  7214.       END IF
  7215.       CALL PGMOVE(XX,YY)
  7216.       END
  7217. C*PGCLOS -- close the selected graphics device
  7218. C%void cpgclos(void);
  7219. C+
  7220.       SUBROUTINE PGCLOS
  7221. C
  7222. C Close the currently selected graphics device. After the device has
  7223. C been closed, either another open device must be selected with PGSLCT
  7224. C or another device must be opened with PGOPEN before any further
  7225. C plotting can be done. If the call to PGCLOS is omitted, some or all 
  7226. C of the plot may be lost.
  7227. C
  7228. C [This routine was added to PGPLOT in Version 5.1.0. Older programs
  7229. C use PGEND instead.]
  7230. C
  7231. C Arguments: none
  7232. C--
  7233. C 22-Dec-1995 - new routine, derived from the old PGEND.
  7234. C-----------------------------------------------------------------------
  7235.       INCLUDE 'f77.PGPLOT/IN'
  7236.       CHARACTER*16 DEFSTR
  7237.       LOGICAL PGNOTO
  7238. C
  7239.       IF (.NOT.PGNOTO('PGCLOS')) THEN
  7240.          CALL GRTERM
  7241.          IF (PGPRMP(PGID)) THEN
  7242.             CALL GRQCAP(DEFSTR)
  7243.             IF (DEFSTR(8:8).EQ.'V') CALL GRPROM
  7244.          END IF
  7245.          CALL GRCLOS
  7246.          PGDEVS(PGID) = 0
  7247.          PGID = 0
  7248.       END IF
  7249. C     WRITE (*,*) 'PGCLOS', PGID, ':', PGDEVS
  7250.       END
  7251.       SUBROUTINE PGCN01(Z, MX, MY, IA, IB, JA, JB, Z0, PLOT,
  7252.      1                  FLAGS, IS, JS, SDIR)
  7253. C
  7254. C Support routine for PGCNSC. This routine draws a continuous contour,
  7255. C starting at the specified point, until it either crosses the edge of
  7256. C the array or closes on itself.
  7257. C-----------------------------------------------------------------------
  7258.       INTEGER UP, DOWN, LEFT, RIGHT
  7259.       PARAMETER (UP=1, DOWN=2, LEFT=3, RIGHT=4)
  7260.       INTEGER  MAXEMX, MAXEMY
  7261.       PARAMETER (MAXEMX=100, MAXEMY=100)
  7262.       LOGICAL FLAGS(MAXEMX,MAXEMY,2)
  7263.       INTEGER MX, MY, IA, IB, JA, JB, IS, JS, I, J, II, JJ, DIR, SDIR
  7264.       REAL Z(MX,*)
  7265.       REAL Z0, X, Y, STARTX, STARTY
  7266.       EXTERNAL PLOT
  7267. C
  7268.       I = IS
  7269.       J = JS
  7270.       DIR = SDIR
  7271.       II = 1+I-IA
  7272.       JJ = 1+J-JA
  7273.       IF (DIR.EQ.UP .OR. DIR.EQ.DOWN) THEN
  7274.           X = REAL(I) + (Z0-Z(I,J))/(Z(I+1,J)-Z(I,J))
  7275.           Y = REAL(J)
  7276.       ELSE
  7277.           X = REAL(I)
  7278.           Y = REAL(J) + (Z0-Z(I,J))/(Z(I,J+1)-Z(I,J))
  7279.       END IF
  7280. CD    WRITE (*,*) 'SEGMENT'
  7281. C
  7282. C Move to start of contour and record starting point.
  7283. C
  7284.       CALL PLOT(0, X, Y, Z0)
  7285.       STARTX = X
  7286.       STARTY = Y
  7287. C
  7288. C We have reached grid-point (I,J) going in direction DIR (UP, DOWN,
  7289. C LEFT, or RIGHT). Look at the other three sides of the cell we are
  7290. C entering to decide where to go next. It is important to look to the
  7291. C two sides before looking straight ahead, in order to avoid self-
  7292. C intersecting contours. If all 3 sides have unused crossing-points,
  7293. C the cell is "degenerate" and we have to decide which of two possible 
  7294. C pairs of contour segments to draw; at present we make an arbitrary 
  7295. C choice. If we have reached the edge of the array, we have
  7296. C finished drawing an unclosed contour. If none of the other three
  7297. C sides of the cell have an unused crossing-point, we must have
  7298. C completed a closed contour, which requires a final segment back to
  7299. C the starting point.
  7300. C
  7301.   100 CONTINUE
  7302. CD    WRITE (*,*) I,J,DIR
  7303.       II = 1 + I - IA
  7304.       JJ = 1 + J - JA
  7305.       GOTO (110, 120, 130, 140), DIR
  7306. C
  7307. C DIR = UP
  7308. C
  7309.   110 CONTINUE
  7310.       FLAGS(II,JJ,1) = .FALSE.
  7311.       IF (J.EQ.JB) THEN
  7312.           RETURN
  7313.       ELSE IF (FLAGS(II,JJ,2)) THEN
  7314.           DIR = LEFT
  7315.           GOTO 200
  7316.       ELSE IF (FLAGS(II+1,JJ,2)) THEN
  7317.           DIR = RIGHT
  7318.           I = I+1
  7319.           GOTO 200
  7320.       ELSE IF (FLAGS(II,JJ+1,1)) THEN
  7321. C!        DIR = UP
  7322.           J = J+1
  7323.           GOTO 250
  7324.       ELSE
  7325.           GOTO 300
  7326.       END IF
  7327. C
  7328. C DIR = DOWN
  7329. C
  7330.   120 CONTINUE
  7331.       FLAGS(II,JJ,1) = .FALSE.
  7332.       IF (J.EQ.JA) THEN
  7333.           RETURN
  7334.       ELSE IF (FLAGS(II+1,JJ-1,2)) THEN
  7335.           DIR = RIGHT
  7336.           I = I+1
  7337.           J = J-1
  7338.           GOTO 200
  7339.       ELSE IF (FLAGS(II,JJ-1,2)) THEN
  7340.           DIR = LEFT
  7341.           J = J-1
  7342.           GOTO 200
  7343.       ELSE IF (FLAGS(II,JJ-1,1)) THEN
  7344. C!        DIR = DOWN
  7345.           J = J-1
  7346.           GOTO 250
  7347.       ELSE
  7348.           GOTO 300
  7349.       END IF
  7350. C
  7351. C DIR = LEFT
  7352. C
  7353.   130 CONTINUE
  7354.       FLAGS(II,JJ,2) = .FALSE.
  7355.       IF (I.EQ.IA) THEN
  7356.           RETURN
  7357.       ELSE IF (FLAGS(II-1,JJ,1)) THEN
  7358.           DIR = DOWN
  7359.           I = I-1
  7360.           GOTO 250
  7361.       ELSE IF (FLAGS(II-1,JJ+1,1)) THEN
  7362.           DIR = UP
  7363.           I = I-1
  7364.           J = J+1
  7365.           GOTO 250
  7366.       ELSE IF (FLAGS(II-1,JJ,2)) THEN
  7367. C!        DIR = LEFT
  7368.           I = I-1
  7369.           GOTO 200
  7370.       ELSE
  7371.           GOTO 300
  7372.       END IF
  7373. C
  7374. C DIR = RIGHT
  7375. C
  7376.   140 CONTINUE
  7377.       FLAGS(II,JJ,2) = .FALSE.
  7378.       IF (I.EQ.IB) THEN
  7379.           RETURN
  7380.       ELSE IF (FLAGS(II,JJ+1,1)) THEN
  7381.           DIR = UP
  7382.           J = J+1
  7383.           GOTO 250
  7384.       ELSE IF (FLAGS(II,JJ,1)) THEN
  7385.           DIR = DOWN
  7386.           GOTO 250
  7387.       ELSE IF (FLAGS(II+1,JJ,2)) THEN
  7388. C!        DIR = RIGHT
  7389.           I = I+1
  7390.           GOTO 200
  7391.       ELSE
  7392.           GOTO 300
  7393.       END IF
  7394. C
  7395. C Draw a segment of the contour.
  7396. C
  7397.   200 X = REAL(I)
  7398.       Y = REAL(J) + (Z0-Z(I,J))/(Z(I,J+1)-Z(I,J))
  7399.       CALL PLOT(1,X,Y,Z0)
  7400.       GOTO 100
  7401.   250 X = REAL(I) + (Z0-Z(I,J))/(Z(I+1,J)-Z(I,J))
  7402.       Y = REAL(J)
  7403.       CALL PLOT(1,X,Y,Z0)
  7404.       GOTO 100
  7405. C
  7406. C Close the contour and go look for another one.
  7407. C
  7408.   300 CALL PLOT(1,STARTX,STARTY,Z0)
  7409.       RETURN
  7410. C
  7411.       END
  7412.       SUBROUTINE PGCNSC (Z, MX, MY, IA, IB, JA, JB, Z0, PLOT)
  7413.       INTEGER MX, MY, IA, IB, JA, JB
  7414.       REAL Z(MX,*)
  7415.       REAL Z0
  7416.       EXTERNAL PLOT
  7417. C
  7418. C PGPLOT (internal routine): Draw a single contour.  This routine is
  7419. C called by PGCONT, but may be called directly by the user.
  7420. C
  7421. C Arguments:
  7422. C
  7423. C Z (real array dimension MX,MY, input): the array of function values.
  7424. C MX,MY (integer, input): actual declared dimension of Z(*,*).
  7425. C IA,IB (integer, input): inclusive range of the first index of Z to be
  7426. C       contoured.
  7427. C JA,JB (integer, input): inclusive range of the second index of Z to
  7428. C       be contoured.
  7429. C Z0 (real, input): the contour level sought.
  7430. C PLOT (the name of a subroutine declared EXTERNAL in the calling
  7431. C       routine): this routine is called by PGCNSC to do all graphical
  7432. C       output. The calling sequence is CALL PLOT(K,X,Y,Z) where Z is
  7433. C       the contour level, (X,Y) are the coordinates of a point (in the
  7434. C       inclusive range I1<X<I2, J1<Y<J2, and if K is 0, the routine is
  7435. C       to move then pen to (X,Y); if K is 1, it is to draw a line from
  7436. C       the current position to (X,Y).
  7437. C
  7438. C NOTE:  the intervals (IA,IB) and (JA,JB) must not exceed the
  7439. C dimensions of an internal array. These are currently set at 100.
  7440. C--
  7441. C 17-Sep-1989 - Completely rewritten [TJP]. The algorithm is my own,
  7442. C               but it is probably not original. It could probably be
  7443. C               coded more briefly, if not as clearly.
  7444. C  1-May-1994 - Modified to draw contours anticlockwise about maxima,
  7445. C               to prevent contours at different levels from
  7446. C               crossing in degenerate cells [TJP].
  7447. C-----------------------------------------------------------------------
  7448.       INTEGER UP, DOWN, LEFT, RIGHT
  7449.       PARAMETER (UP=1, DOWN=2, LEFT=3, RIGHT=4)
  7450.       INTEGER  MAXEMX, MAXEMY
  7451.       PARAMETER (MAXEMX=100, MAXEMY=100)
  7452. C
  7453.       LOGICAL FLAGS(MAXEMX,MAXEMY,2), RANGE
  7454.       INTEGER I, J, II, JJ, DIR
  7455.       REAL Z1, Z2, Z3, P, P1, P2
  7456. C
  7457. C The statement function RANGE decides whether a contour at level P
  7458. C crosses the line between two gridpoints with values P1 and P2. It is
  7459. C important that a contour cannot cross a line with equal endpoints.
  7460. C
  7461.       RANGE (P,P1,P2) = (P.GT.MIN(P1,P2)) .AND. (P.LE.MAX(P1,P2))
  7462.      1                  .AND. (P1.NE.P2)
  7463. C
  7464. C Check for errors.
  7465. C
  7466.       IF ( (IB-IA+1) .GT. MAXEMX .OR.  (JB-JA+1) .GT. MAXEMY ) THEN
  7467.           CALL GRWARN('PGCNSC - array index range exceeds'//
  7468.      1                ' built-in limit of 100')
  7469.           RETURN
  7470.       END IF
  7471. C
  7472. C Initialize the flags. The first flag for a gridpoint is set if
  7473. C the contour crosses the line segment to the right of the gridpoint
  7474. C (joining [I,J] to [I+1,J]); the second flag is set if if it crosses
  7475. C the line segment above the gridpoint (joining [I,J] to [I,J+1]).
  7476. C The top and right edges require special treatment. (For purposes
  7477. C of description only, we assume I increases horizontally to the right
  7478. C and J increases vertically upwards.)
  7479. C
  7480.       DO 20 I=IA,IB
  7481.           II = I-IA+1
  7482.           DO 10 J=JA,JB
  7483.               JJ = J-JA+1
  7484.               Z1 = Z(I,J)
  7485.               FLAGS(II,JJ,1) = .FALSE.
  7486.               FLAGS(II,JJ,2) = .FALSE.
  7487.               IF (I.LT.IB) THEN
  7488.                 Z2 = Z(I+1,J)
  7489.                 IF (RANGE(Z0,Z1,Z2)) FLAGS(II,JJ,1) = .TRUE.
  7490.               END IF
  7491.               IF (J.LT.JB) THEN
  7492.                 Z3 = Z(I,J+1)
  7493.                 IF (RANGE(Z0,Z1,Z3)) FLAGS(II,JJ,2) = .TRUE.
  7494.               END IF
  7495.    10     CONTINUE
  7496.    20 CONTINUE
  7497. C
  7498. C Search the edges of the array for the start of an unclosed contour.
  7499. C Note that (if the algorithm is implemented correctly) all unclosed
  7500. C contours must begin and end at the edge of the array. When one is
  7501. C found, call PGCN01 to draw the contour, telling it the correct
  7502. C starting direction so that it follows the contour into the array
  7503. C instead of out of it. A contour is only started if the higher
  7504. C ground lies to the left: this is to enforce the direction convention
  7505. C that contours are drawn anticlockwise around maxima. If the high
  7506. C ground lies to the right, we will find the other end of the contour
  7507. C and start there.
  7508. C
  7509. C Bottom edge.
  7510. C
  7511.       J = JA
  7512.       JJ = J-JA+1
  7513.       DO 26 I=IA,IB-1
  7514.           II = I-IA+1
  7515.           IF (FLAGS(II,JJ,1) .AND. (Z(I,J).GT.Z(I+1,J)))
  7516.      1          CALL PGCN01(Z, MX, MY, IA, IB, JA, JB,
  7517.      2                      Z0, PLOT, FLAGS, I, J, UP)
  7518.    26 CONTINUE
  7519. C
  7520. C Right edge.
  7521. C
  7522.       I = IB
  7523.       II = I-IA+1
  7524.       DO 27 J=JA,JB-1
  7525.           JJ = J-JA+1
  7526.           IF (FLAGS(II,JJ,2) .AND. (Z(I,J).GT.Z(I,J+1)))
  7527.      1          CALL PGCN01(Z, MX, MY, IA, IB, JA, JB,
  7528.      2                      Z0, PLOT, FLAGS, I, J, LEFT)
  7529.    27 CONTINUE
  7530. C
  7531. C Top edge.
  7532. C
  7533.       J = JB
  7534.       JJ = J-JA+1
  7535.       DO 28 I=IB-1,IA,-1
  7536.           II = I-IA+1
  7537.           IF (FLAGS(II,JJ,1) .AND. (Z(I+1,J).GT.Z(I,J)))
  7538.      1          CALL PGCN01(Z, MX, MY, IA, IB, JA, JB,
  7539.      2                      Z0, PLOT, FLAGS, I, J, DOWN)
  7540.    28 CONTINUE
  7541. C
  7542. C Left edge.
  7543. C
  7544.       I = IA
  7545.       II = I-IA+1
  7546.       DO 29 J=JB-1,JA,-1
  7547.           JJ = J-JA+1
  7548.           IF (FLAGS(II,JJ,2)  .AND. (Z(I,J+1).GT.Z(I,J)))
  7549.      1          CALL PGCN01(Z, MX, MY, IA, IB, JA, JB,
  7550.      2                      Z0, PLOT, FLAGS, I, J, RIGHT)
  7551.    29 CONTINUE
  7552. C
  7553. C Now search the interior of the array for a crossing point, which will
  7554. C lie on a closed contour (because all unclosed contours have been
  7555. C eliminated). It is sufficient to search just the horizontal crossings
  7556. C (or the vertical ones); any closed contour must cross a horizontal
  7557. C and a vertical gridline. PGCN01 assumes that when it cannot proceed
  7558. C any further, it has reached the end of a closed contour. Thus all
  7559. C unclosed contours must be eliminated first.
  7560. C
  7561.       DO 40 I=IA+1,IB-1
  7562.           II = I-IA+1
  7563.           DO 30 J=JA+1,JB-1
  7564.               JJ = J-JA+1
  7565.               IF (FLAGS(II,JJ,1)) THEN
  7566.                   DIR = UP
  7567.                   IF (Z(I+1,J).GT. Z(I,J)) DIR = DOWN
  7568.                   CALL PGCN01(Z, MX, MY, IA, IB, JA, JB,
  7569.      1                        Z0, PLOT, FLAGS, I, J, DIR)
  7570.  
  7571.               END IF
  7572.    30     CONTINUE
  7573.    40 CONTINUE
  7574. C
  7575. C We didn't find any more crossing points: we're finished.
  7576. C
  7577.       RETURN
  7578.       END
  7579. C*PGCONB -- contour map of a 2D data array, with blanking
  7580. C%void cpgconb(const float *a, int idim, int jdim, int i1, int i2, \
  7581. C% int j1, int j2, const float *c, int nc, const float *tr, \
  7582. C% float blank);
  7583. C+
  7584.       SUBROUTINE PGCONB (A, IDIM, JDIM, I1, I2, J1, J2, C, NC, TR, 
  7585.      1                   BLANK)
  7586.       INTEGER IDIM, JDIM, I1, I2, J1, J2, NC
  7587.       REAL    A(IDIM,JDIM), C(*), TR(6), BLANK
  7588. C
  7589. C Draw a contour map of an array. This routine is the same as PGCONS,
  7590. C except that array elements that have the "magic value" defined by
  7591. C argument BLANK are ignored, making gaps in the contour map. The
  7592. C routine may be useful for data measured on most but not all of the
  7593. C points of a grid.
  7594. C
  7595. C Arguments:
  7596. C  A      (input)  : data array.
  7597. C  IDIM   (input)  : first dimension of A.
  7598. C  JDIM   (input)  : second dimension of A.
  7599. C  I1,I2  (input)  : range of first index to be contoured (inclusive).
  7600. C  J1,J2  (input)  : range of second index to be contoured (inclusive).
  7601. C  C      (input)  : array of contour levels (in the same units as the
  7602. C                    data in array A); dimension at least NC.
  7603. C  NC     (input)  : number of contour levels (less than or equal to
  7604. C                    dimension of C). The absolute value of this
  7605. C                    argument is used (for compatibility with PGCONT,
  7606. C                    where the sign of NC is significant).
  7607. C  TR     (input)  : array defining a transformation between the I,J
  7608. C                    grid of the array and the world coordinates. The
  7609. C                    world coordinates of the array point A(I,J) are
  7610. C                    given by:
  7611. C                      X = TR(1) + TR(2)*I + TR(3)*J
  7612. C                      Y = TR(4) + TR(5)*I + TR(6)*J
  7613. C                    Usually TR(3) and TR(5) are zero - unless the
  7614. C                    coordinate transformation involves a rotation
  7615. C                    or shear.
  7616. C  BLANK   (input) : elements of array A that are exactly equal to
  7617. C                    this value are ignored (blanked).
  7618. C--
  7619. C 21-Sep-1989 - Derived from PGCONS [TJP].
  7620. C-----------------------------------------------------------------------
  7621.       INTEGER  I, IC, ICORN, IDELT(6), J, K, NPT
  7622.       INTEGER  IOFF(8), JOFF(8), IENC, ITMP, JTMP, ILO, ITOT
  7623.       LOGICAL  PGNOTO
  7624.       REAL     CTR, DELTA, DVAL(5), XX, YY, X(4), Y(4)
  7625.       INTRINSIC ABS
  7626.       DATA     IDELT/0,-1,-1,0,0,-1/
  7627.       DATA     IOFF/-2,-2,-1,-1, 0, 0, 1, 1/
  7628.       DATA     JOFF/ 0,-1,-2, 1,-2, 1,-1, 0/
  7629. C
  7630. C Check arguments.
  7631. C
  7632.       IF (PGNOTO('PGCONB')) RETURN
  7633.       IF (I1.LT.1 .OR. I2.GT.IDIM .OR. I1.GE.I2 .OR.
  7634.      1    J1.LT.1 .OR. J2.GT.JDIM .OR. J1.GE.J2) RETURN
  7635.       IF (NC.EQ.0) RETURN
  7636.       CALL PGBBUF
  7637. C
  7638.       DO 130 J=J1+1,J2
  7639.       DO 130 I=I1+1,I2
  7640.           DVAL(1) = A(I-1,J)
  7641.           DVAL(2) = A(I-1,J-1)
  7642.           DVAL(3) = A(I,J-1)
  7643.           DVAL(4) = A(I,J)
  7644.           DVAL(5) = DVAL(1)
  7645.           IF (DVAL(1).EQ.BLANK .OR. DVAL(2).EQ.BLANK .OR.
  7646.      1        DVAL(3).EQ.BLANK .OR. DVAL(4).EQ.BLANK) GOTO 130
  7647.       DO 110 IC=1,ABS(NC)
  7648.           CTR = C(IC)
  7649.           NPT = 0
  7650.           DO 120 ICORN=1,4
  7651.           IF( (DVAL(ICORN).LT.CTR .AND. DVAL(ICORN+1).LT.CTR)
  7652.      1    .OR.(DVAL(ICORN).GE.CTR .AND. DVAL(ICORN+1).GE.CTR) ) GOTO 120
  7653.             NPT=NPT+1
  7654.             DELTA = (CTR-DVAL(ICORN))/(DVAL(ICORN+1)-DVAL(ICORN))
  7655.             GOTO (60,70,60,70), ICORN
  7656. C
  7657.    60       XX = I+IDELT(ICORN+1)
  7658.             YY = REAL(J+IDELT(ICORN)) + 
  7659.      1           DELTA*REAL(IDELT(ICORN+1)-IDELT(ICORN))
  7660.             GOTO 80
  7661. C
  7662.    70       XX = REAL(I+IDELT(ICORN+1)) +
  7663.      1           DELTA*REAL(IDELT(ICORN+2)-IDELT(ICORN+1))
  7664.             YY  = J+IDELT(ICORN)
  7665. C
  7666.    80       X(NPT) = TR(1) + TR(2)*XX + TR(3)*YY
  7667.             Y(NPT) = TR(4) + TR(5)*XX + TR(6)*YY
  7668. C
  7669.   120     CONTINUE
  7670.           IF (NPT.EQ.2) THEN
  7671. C             -- Contour crosses two sides of cell. Draw line-segment.
  7672.               CALL PGMOVE(X(1),Y(1))
  7673.               CALL PGDRAW(X(2),Y(2))
  7674.           ELSE IF (NPT.EQ.4) THEN
  7675. C             -- The 'ambiguous' case.  The routine must draw two line
  7676. C             segments here and there are two ways to do so.  The
  7677. C             following 4 lines would implement the original PGPLOT
  7678. C             method:
  7679. C            CALL PGCP(0,X(1),Y(1),CTR)
  7680. C            CALL PGCP(1,X(2),Y(2),CTR)
  7681. C            CALL PGCP(0,X(3),Y(3),CTR)
  7682. C            CALL PGCP(1,X(4),Y(4),CTR)
  7683. C            -- Choose between \\ and // based on the 8 points just
  7684. C            outside the current box.  If half or more of these points
  7685. C            lie below the contour level, then draw the lines such that
  7686. C            the high corners lie between the lines, otherwise, draw
  7687. C            the lines such that the low corners are enclosed.  Care is
  7688. C            taken to avoid going off the edge.
  7689.             ITOT=0
  7690.             ILO=0
  7691.             DO 140 K=1,8
  7692.                ITMP=I+IOFF(K)
  7693.                JTMP=J+JOFF(K)
  7694.                IF(ITMP.LT.I1 .OR. ITMP.GT.I2) GOTO 140
  7695.                IF(JTMP.LT.J1 .OR. JTMP.GT.J2) GOTO 140
  7696.                IF(A(ITMP,JTMP).EQ.BLANK) GOTO 140
  7697.                ITOT=ITOT+1
  7698.                IF(A(ITMP,JTMP).LT.CTR) ILO=ILO+1
  7699.   140       CONTINUE
  7700.             IENC=+1
  7701.             IF(ILO.LT.ITOT/2) IENC=-1
  7702.             IF(IENC.LT.0 .AND. DVAL(1).LT.CTR .OR.
  7703.      :         IENC.GT.0 .AND. DVAL(1).GE.CTR) THEN
  7704.                CALL PGMOVE(X(1),Y(1))
  7705.                CALL PGDRAW(X(2),Y(2))
  7706.                CALL PGMOVE(X(3),Y(3))
  7707.                CALL PGDRAW(X(4),Y(4))
  7708.             ELSE
  7709.                CALL PGMOVE(X(1),Y(1))
  7710.                CALL PGDRAW(X(4),Y(4))
  7711.                CALL PGMOVE(X(3),Y(3))
  7712.                CALL PGDRAW(X(2),Y(2))
  7713.             END IF
  7714.           END IF
  7715.   110     CONTINUE
  7716.   130 CONTINUE
  7717. C
  7718.       CALL PGEBUF
  7719.       END
  7720. C*PGCONL -- label contour map of a 2D data array 
  7721. C%void cpgconl(const float *a, int idim, int jdim, int i1, int i2, \
  7722. C% int j1, int j2, float c, const float *tr, const char *label, \
  7723. C% int intval, int minint);
  7724. C+
  7725.       SUBROUTINE PGCONL (A, IDIM, JDIM, I1, I2, J1, J2, C, TR,
  7726.      1                   LABEL, INTVAL, MININT)
  7727.       INTEGER IDIM, JDIM, I1, J1, I2, J2, INTVAL, MININT
  7728.       REAL A(IDIM,JDIM), C, TR(6)
  7729.       CHARACTER*(*) LABEL
  7730. C
  7731. C Label a contour map drawn with routine PGCONT. Routine PGCONT should
  7732. C be called first to draw the contour lines, then this routine should be
  7733. C called to add the labels. Labels are written at intervals along the
  7734. C contour lines, centered on the contour lines with lettering aligned
  7735. C in the up-hill direction. Labels are opaque, so a part of the under-
  7736. C lying contour line is obscured by the label. Labels use the current
  7737. C attributes (character height, line width, color index, character
  7738. C font).
  7739. C
  7740. C The first 9 arguments are the same as those supplied to PGCONT, and
  7741. C should normally be identical to those used with PGCONT. Note that
  7742. C only one contour level can be specified; tolabel more contours, call
  7743. C PGCONL for each level.
  7744. C
  7745. C The Label is supplied as a character string in argument LABEL.
  7746. C
  7747. C The spacing of labels along the contour is specified by parameters
  7748. C INTVAL and MININT. The routine follows the contour through the
  7749. C array, counting the number of cells that the contour crosses. The
  7750. C first label will be written in the MININT'th cell, and additional
  7751. C labels will be written every INTVAL cells thereafter. A contour
  7752. C that crosses less than MININT cells will not be labelled. Some
  7753. C experimentation may be needed to get satisfactory results; a good
  7754. C place to start is INTVAL=20, MININT=10.
  7755. C
  7756. C Arguments:
  7757. C  A      (input) : data array.
  7758. C  IDIM   (input) : first dimension of A.
  7759. C  JDIM   (input) : second dimension of A.
  7760. C  I1, I2 (input) : range of first index to be contoured (inclusive).
  7761. C  J1, J2 (input) : range of second index to be contoured (inclusive).
  7762. C  C      (input) : the level of the contour to be labelled (one of the
  7763. C                   values given to PGCONT).
  7764. C  TR     (input) : array defining a transformation between the I,J
  7765. C                   grid of the array and the world coordinates.
  7766. C                   The world coordinates of the array point A(I,J)
  7767. C                   are given by:
  7768. C                     X = TR(1) + TR(2)*I + TR(3)*J
  7769. C                     Y = TR(4) + TR(5)*I + TR(6)*J
  7770. C                   Usually TR(3) and TR(5) are zero - unless the
  7771. C                   coordinate transformation involves a rotation or
  7772. C                   shear.
  7773. C  LABEL  (input) : character strings to be used to label the specified
  7774. C                   contour. Leading and trailing blank spaces are
  7775. C                   ignored.
  7776. C  INTVAL (input) : spacing along the contour between labels, in
  7777. C                   grid cells.
  7778. C  MININT (input) : contours that cross less than MININT cells
  7779. C                   will not be labelled.
  7780. C--
  7781. C (5-May-1994)  New routine; this routine is virtually identical to
  7782. C               PGCONT, but calls PGCONX with a different external
  7783. C               routine [TJP].
  7784. C-----------------------------------------------------------------------
  7785.       INCLUDE  'f77.PGPLOT/IN'
  7786.       INTEGER  I
  7787.       LOGICAL  PGNOTO
  7788.       EXTERNAL PGCL
  7789. C
  7790.       IF (PGNOTO('PGCONL')) RETURN
  7791. C
  7792. C Save TRANS matrix and other parameters.
  7793. C
  7794.       DO 10 I=1,6
  7795.           TRANS(I) = TR(I)
  7796.    10 CONTINUE
  7797.       PGCINT = INTVAL
  7798.       PGCMIN = MININT
  7799.       PGCLAB = LABEL
  7800. C
  7801. C Use PGCONX with external function PGCL.
  7802. C
  7803.       CALL PGCONX (A, IDIM, JDIM, I1, I2, J1, J2, C, 1, PGCL)
  7804. C
  7805.       END
  7806. C*PGCONS -- contour map of a 2D data array (fast algorithm)
  7807. C%void cpgcons(const float *a, int idim, int jdim, int i1, int i2, \
  7808. C% int j1, int j2, const float *c, int nc, const float *tr);
  7809. C+
  7810.       SUBROUTINE PGCONS (A, IDIM, JDIM, I1, I2, J1, J2, C, NC, TR)
  7811.       INTEGER IDIM, JDIM, I1, I2, J1, J2, NC
  7812.       REAL    A(IDIM,JDIM), C(*), TR(6)
  7813. C
  7814. C Draw a contour map of an array. The map is truncated if
  7815. C necessary at the boundaries of the viewport.  Each contour line is
  7816. C drawn with the current line attributes (color index, style, and
  7817. C width).  This routine, unlike PGCONT, does not draw each contour as a
  7818. C continuous line, but draws the straight line segments composing each
  7819. C contour in a random order.  It is thus not suitable for use on pen
  7820. C plotters, and it usually gives unsatisfactory results with dashed or
  7821. C dotted lines.  It is, however, faster than PGCONT, especially if
  7822. C several contour levels are drawn with one call of PGCONS.
  7823. C
  7824. C Arguments:
  7825. C  A      (input)  : data array.
  7826. C  IDIM   (input)  : first dimension of A.
  7827. C  JDIM   (input)  : second dimension of A.
  7828. C  I1,I2  (input)  : range of first index to be contoured (inclusive).
  7829. C  J1,J2  (input)  : range of second index to be contoured (inclusive).
  7830. C  C      (input)  : array of contour levels (in the same units as the
  7831. C                    data in array A); dimension at least NC.
  7832. C  NC     (input)  : number of contour levels (less than or equal to
  7833. C                    dimension of C). The absolute value of this
  7834. C                    argument is used (for compatibility with PGCONT,
  7835. C                    where the sign of NC is significant).
  7836. C  TR     (input)  : array defining a transformation between the I,J
  7837. C                    grid of the array and the world coordinates. The
  7838. C                    world coordinates of the array point A(I,J) are
  7839. C                    given by:
  7840. C                      X = TR(1) + TR(2)*I + TR(3)*J
  7841. C                      Y = TR(4) + TR(5)*I + TR(6)*J
  7842. C                    Usually TR(3) and TR(5) are zero - unless the
  7843. C                    coordinate transformation involves a rotation
  7844. C                    or shear.
  7845. C--
  7846. C 27-Aug-1984 - [TJP].
  7847. C 21-Sep-1989 - Better treatment of the 'ambiguous' case [A. Tennant];
  7848. C               compute world coordinates internally and eliminate
  7849. C               dependence on common block [TJP].
  7850. C-----------------------------------------------------------------------
  7851.       INTEGER  I, IC, ICORN, IDELT(6), J, K, NPT
  7852.       INTEGER  IOFF(8), JOFF(8), IENC, ITMP, JTMP, ILO, ITOT
  7853.       LOGICAL  PGNOTO
  7854.       REAL     CTR, DELTA, DVAL(5), XX, YY, X(4), Y(4)
  7855.       INTRINSIC ABS
  7856.       DATA     IDELT/0,-1,-1,0,0,-1/
  7857.       DATA     IOFF/-2,-2,-1,-1, 0, 0, 1, 1/
  7858.       DATA     JOFF/ 0,-1,-2, 1,-2, 1,-1, 0/
  7859. C
  7860. C Check arguments.
  7861. C
  7862.       IF (PGNOTO('PGCONS')) RETURN
  7863.       IF (I1.LT.1 .OR. I2.GT.IDIM .OR. I1.GE.I2 .OR.
  7864.      1    J1.LT.1 .OR. J2.GT.JDIM .OR. J1.GE.J2) RETURN
  7865.       IF (NC.EQ.0) RETURN
  7866.       CALL PGBBUF
  7867. C
  7868.       DO 130 J=J1+1,J2
  7869.       DO 130 I=I1+1,I2
  7870.           DVAL(1) = A(I-1,J)
  7871.           DVAL(2) = A(I-1,J-1)
  7872.           DVAL(3) = A(I,J-1)
  7873.           DVAL(4) = A(I,J)
  7874.           DVAL(5) = DVAL(1)
  7875.       DO 110 IC=1,ABS(NC)
  7876.           CTR = C(IC)
  7877.           NPT = 0
  7878.           DO 120 ICORN=1,4
  7879.           IF( (DVAL(ICORN).LT.CTR .AND. DVAL(ICORN+1).LT.CTR)
  7880.      1    .OR.(DVAL(ICORN).GE.CTR .AND. DVAL(ICORN+1).GE.CTR) ) GOTO 120
  7881.             NPT=NPT+1
  7882.             DELTA = (CTR-DVAL(ICORN))/(DVAL(ICORN+1)-DVAL(ICORN))
  7883.             GOTO (60,70,60,70), ICORN
  7884. C
  7885.    60       XX = I+IDELT(ICORN+1)
  7886.             YY = REAL(J+IDELT(ICORN)) + 
  7887.      1           DELTA*REAL(IDELT(ICORN+1)-IDELT(ICORN))
  7888.             GOTO 80
  7889. C
  7890.    70       XX = REAL(I+IDELT(ICORN+1)) +
  7891.      1           DELTA*REAL(IDELT(ICORN+2)-IDELT(ICORN+1))
  7892.             YY  = J+IDELT(ICORN)
  7893. C
  7894.    80       X(NPT) = TR(1) + TR(2)*XX + TR(3)*YY
  7895.             Y(NPT) = TR(4) + TR(5)*XX + TR(6)*YY
  7896. C
  7897.   120     CONTINUE
  7898.           IF (NPT.EQ.2) THEN
  7899. C             -- Contour crosses two sides of cell. Draw line-segment.
  7900.               CALL PGMOVE(X(1),Y(1))
  7901.               CALL PGDRAW(X(2),Y(2))
  7902.           ELSE IF (NPT.EQ.4) THEN
  7903. C             -- The 'ambiguous' case.  The routine must draw two line
  7904. C             segments here and there are two ways to do so.  The
  7905. C             following 4 lines would implement the original PGPLOT
  7906. C             method:
  7907. C            CALL PGCP(0,X(1),Y(1),CTR)
  7908. C            CALL PGCP(1,X(2),Y(2),CTR)
  7909. C            CALL PGCP(0,X(3),Y(3),CTR)
  7910. C            CALL PGCP(1,X(4),Y(4),CTR)
  7911. C            -- Choose between \\ and // based on the 8 points just
  7912. C            outside the current box.  If half or more of these points
  7913. C            lie below the contour level, then draw the lines such that
  7914. C            the high corners lie between the lines, otherwise, draw
  7915. C            the lines such that the low corners are enclosed.  Care is
  7916. C            taken to avoid going off the edge.
  7917.             ITOT=0
  7918.             ILO=0
  7919.             DO 140 K=1,8
  7920.                ITMP=I+IOFF(K)
  7921.                JTMP=J+JOFF(K)
  7922.                IF(ITMP.LT.I1 .OR. ITMP.GT.I2) GOTO 140
  7923.                IF(JTMP.LT.J1 .OR. JTMP.GT.J2) GOTO 140
  7924.                ITOT=ITOT+1
  7925.                IF(A(ITMP,JTMP).LT.CTR) ILO=ILO+1
  7926.   140       CONTINUE
  7927.             IENC=+1
  7928.             IF(ILO.LT.ITOT/2) IENC=-1
  7929.             IF(IENC.LT.0 .AND. DVAL(1).LT.CTR .OR.
  7930.      :         IENC.GT.0 .AND. DVAL(1).GE.CTR) THEN
  7931.                CALL PGMOVE(X(1),Y(1))
  7932.                CALL PGDRAW(X(2),Y(2))
  7933.                CALL PGMOVE(X(3),Y(3))
  7934.                CALL PGDRAW(X(4),Y(4))
  7935.             ELSE
  7936.                CALL PGMOVE(X(1),Y(1))
  7937.                CALL PGDRAW(X(4),Y(4))
  7938.                CALL PGMOVE(X(3),Y(3))
  7939.                CALL PGDRAW(X(2),Y(2))
  7940.             END IF
  7941.           END IF
  7942.   110     CONTINUE
  7943.   130 CONTINUE
  7944. C
  7945.       CALL PGEBUF
  7946.       END
  7947. C*PGCONT -- contour map of a 2D data array (contour-following)
  7948. C%void cpgcont(const float *a, int idim, int jdim, int i1, int i2, \
  7949. C% int j1, int j2, const float *c, int nc, const float *tr);
  7950. C+
  7951.       SUBROUTINE PGCONT (A, IDIM, JDIM, I1, I2, J1, J2, C, NC, TR)
  7952.       INTEGER IDIM, JDIM, I1, J1, I2, J2, NC
  7953.       REAL A(IDIM,JDIM), C(*), TR(6)
  7954. C
  7955. C Draw a contour map of an array.  The map is truncated if
  7956. C necessary at the boundaries of the viewport.  Each contour line
  7957. C is drawn with the current line attributes (color index, style, and
  7958. C width); except that if argument NC is positive (see below), the line
  7959. C style is set by PGCONT to 1 (solid) for positive contours or 2
  7960. C (dashed) for negative contours.
  7961. C
  7962. C Arguments:
  7963. C  A      (input) : data array.
  7964. C  IDIM   (input) : first dimension of A.
  7965. C  JDIM   (input) : second dimension of A.
  7966. C  I1, I2 (input) : range of first index to be contoured (inclusive).
  7967. C  J1, J2 (input) : range of second index to be contoured (inclusive).
  7968. C  C      (input) : array of NC contour levels; dimension at least NC.
  7969. C  NC     (input) : +/- number of contour levels (less than or equal
  7970. C                   to dimension of C). If NC is positive, it is the
  7971. C                   number of contour levels, and the line-style is
  7972. C                   chosen automatically as described above. If NC is
  7973. C                   negative, it is minus the number of contour
  7974. C                   levels, and the current setting of line-style is
  7975. C                   used for all the contours.
  7976. C  TR     (input) : array defining a transformation between the I,J
  7977. C                   grid of the array and the world coordinates.
  7978. C                   The world coordinates of the array point A(I,J)
  7979. C                   are given by:
  7980. C                     X = TR(1) + TR(2)*I + TR(3)*J
  7981. C                     Y = TR(4) + TR(5)*I + TR(6)*J
  7982. C                   Usually TR(3) and TR(5) are zero - unless the
  7983. C                   coordinate transformation involves a rotation or
  7984. C                   shear.
  7985. C--
  7986. C (7-Feb-1983)
  7987. C (24-Aug-1984) Revised to add the option of not automatically
  7988. C       setting the line-style. Sorry about the ugly way this is
  7989. C       done (negative NC); this is the least incompatible way of doing
  7990. C       it (TJP).
  7991. C (21-Sep-1989) Changed to call PGCONX instead of duplicating the code
  7992. C       [TJP].
  7993. C-----------------------------------------------------------------------
  7994.       INCLUDE  'f77.PGPLOT/IN'
  7995.       INTEGER  I
  7996.       LOGICAL  PGNOTO
  7997.       EXTERNAL PGCP
  7998. C
  7999.       IF (PGNOTO('PGCONT')) RETURN
  8000. C
  8001. C Save TRANS matrix.
  8002. C
  8003.       DO 10 I=1,6
  8004.           TRANS(I) = TR(I)
  8005.    10 CONTINUE
  8006. C
  8007. C Use PGCONX with external function PGCP, which applies the TRANS
  8008. C scaling.
  8009. C
  8010.       CALL PGCONX (A, IDIM, JDIM, I1, I2, J1, J2, C, NC, PGCP)
  8011. C
  8012.       END
  8013. C*PGCONX -- contour map of a 2D data array (non rectangular)
  8014. C+
  8015.       SUBROUTINE PGCONX (A, IDIM, JDIM, I1, I2, J1, J2, C, NC, PLOT)
  8016.       INTEGER  IDIM, JDIM, I1, J1, I2, J2, NC
  8017.       REAL     A(IDIM,JDIM), C(*)
  8018.       EXTERNAL PLOT
  8019. C
  8020. C Draw a contour map of an array using a user-supplied plotting
  8021. C routine.  This routine should be used instead of PGCONT when the
  8022. C data are defined on a non-rectangular grid.  PGCONT permits only
  8023. C a linear transformation between the (I,J) grid of the array
  8024. C and the world coordinate system (x,y), but PGCONX permits any
  8025. C transformation to be used, the transformation being defined by a
  8026. C user-supplied subroutine. The nature of the contouring algorithm,
  8027. C however, dictates that the transformation should maintain the
  8028. C rectangular topology of the grid, although grid-points may be
  8029. C allowed to coalesce.  As an example of a deformed rectangular
  8030. C grid, consider data given on the polar grid theta=0.1n(pi/2),
  8031. C for n=0,1,...,10, and r=0.25m, for m=0,1,..,4. This grid
  8032. C contains 55 points, of which 11 are coincident at the origin.
  8033. C The input array for PGCONX should be dimensioned (11,5), and
  8034. C data values should be provided for all 55 elements.  PGCONX can
  8035. C also be used for special applications in which the height of the
  8036. C contour affects its appearance, e.g., stereoscopic views.
  8037. C
  8038. C The map is truncated if necessary at the boundaries of the viewport.
  8039. C Each contour line is drawn with the current line attributes (color
  8040. C index, style, and width); except that if argument NC is positive
  8041. C (see below), the line style is set by PGCONX to 1 (solid) for
  8042. C positive contours or 2 (dashed) for negative contours. Attributes
  8043. C for the contour lines can also be set in the user-supplied
  8044. C subroutine, if desired.
  8045. C
  8046. C Arguments:
  8047. C  A      (input) : data array.
  8048. C  IDIM   (input) : first dimension of A.
  8049. C  JDIM   (input) : second dimension of A.
  8050. C  I1, I2 (input) : range of first index to be contoured (inclusive).
  8051. C  J1, J2 (input) : range of second index to be contoured (inclusive).
  8052. C  C      (input) : array of NC contour levels; dimension at least NC.
  8053. C  NC     (input) : +/- number of contour levels (less than or equal
  8054. C                   to dimension of C). If NC is positive, it is the
  8055. C                   number of contour levels, and the line-style is
  8056. C                   chosen automatically as described above. If NC is
  8057. C                   negative, it is minus the number of contour
  8058. C                   levels, and the current setting of line-style is
  8059. C                   used for all the contours.
  8060. C  PLOT   (input) : the address (name) of a subroutine supplied by
  8061. C                   the user, which will be called by PGCONX to do
  8062. C                   the actual plotting. This must be declared
  8063. C                   EXTERNAL in the program unit calling PGCONX.
  8064. C
  8065. C The subroutine PLOT will be called with four arguments:
  8066. C      CALL PLOT(VISBLE,X,Y,Z)
  8067. C where X,Y (input) are real variables corresponding to
  8068. C I,J indices of the array A. If  VISBLE (input, integer) is 1,
  8069. C PLOT should draw a visible line from the current pen
  8070. C position to the world coordinate point corresponding to (X,Y);
  8071. C if it is 0, it should move the pen to (X,Y). Z is the value
  8072. C of the current contour level, and may be used by PLOT if desired.
  8073. C Example:
  8074. C       SUBROUTINE PLOT (VISBLE,X,Y,Z)
  8075. C       REAL X, Y, Z, XWORLD, YWORLD
  8076. C       INTEGER VISBLE
  8077. C       XWORLD = X*COS(Y) ! this is the user-defined
  8078. C       YWORLD = X*SIN(Y) ! transformation
  8079. C       IF (VISBLE.EQ.0) THEN
  8080. C           CALL PGMOVE (XWORLD, YWORLD)
  8081. C       ELSE
  8082. C           CALL PGDRAW (XWORLD, YWORLD)
  8083. C       END IF
  8084. C       END
  8085. C--
  8086. C 14-Nov-1985 - new routine [TJP].
  8087. C 12-Sep-1989 - correct documentation error [TJP].
  8088. C 22-Apr-1990 - corrected bug in panelling algorithm [TJP].
  8089. C 13-Dec-1990 - make errors non-fatal [TJP].
  8090. C-----------------------------------------------------------------------
  8091.       INTEGER  MAXEMX,MAXEMY
  8092.       PARAMETER (MAXEMX=100)
  8093.       PARAMETER (MAXEMY=100)
  8094.       INTEGER  I
  8095.       INTEGER  NNX,NNY, KX,KY, KI,KJ, IA,IB, JA,JB, LS, PX, PY
  8096.       LOGICAL  STYLE, PGNOTO
  8097. C
  8098. C Check arguments.
  8099. C
  8100.       IF (PGNOTO('PGCONX')) RETURN
  8101.       IF (I1.LT.1 .OR. I2.GT.IDIM .OR. I1.GE.I2 .OR.
  8102.      1    J1.LT.1 .OR. J2.GT.JDIM .OR. J1.GE.J2) THEN
  8103.           CALL GRWARN('PGCONX: invalid range I1:I2, J1:J2')
  8104.           RETURN
  8105.       END IF
  8106.       IF (NC.EQ.0) RETURN
  8107.       STYLE = NC.GT.0
  8108.       CALL PGQLS(LS)
  8109.       CALL PGBBUF
  8110. C
  8111. C Divide arrays into panels not exceeding MAXEMX by MAXEMY for
  8112. C contouring by PGCNSC.
  8113. C
  8114. CD    write (*,*) 'PGCONX window:',i1,i2,j1,j2
  8115.       NNX = I2-I1+1
  8116.       NNY = J2-J1+1
  8117.       KX = MAX(1,(NNX+MAXEMX-2)/(MAXEMX-1))
  8118.       KY = MAX(1,(NNY+MAXEMY-2)/(MAXEMY-1))
  8119.       PX = (NNX+KX-1)/KX
  8120.       PY = (NNY+KY-1)/KY
  8121.       DO 60 KI=1,KX
  8122.           IA = I1 + (KI-1)*PX
  8123.           IB = MIN(I2, IA + PX)
  8124.           DO 50 KJ=1,KY
  8125.               JA = J1 + (KJ-1)*PY
  8126.               JB = MIN(J2, JA + PY)
  8127. C
  8128. C             Draw the contours in one panel.
  8129. C
  8130. CD            write (*,*) 'PGCONX panel:',ia,ib,ja,jb
  8131.               IF (STYLE) CALL PGSLS(1)
  8132.               DO 40 I=1,ABS(NC)
  8133.                   IF (STYLE.AND.(C(I).LT.0.0)) CALL PGSLS(2)
  8134.                   CALL PGCNSC(A,IDIM,JDIM,IA,IB,JA,JB,C(I),PLOT)
  8135.                   IF (STYLE) CALL PGSLS(1)
  8136.    40         CONTINUE
  8137.    50     CONTINUE
  8138.    60 CONTINUE
  8139. C
  8140.       CALL PGSLS(LS)
  8141.       CALL PGEBUF
  8142.       END
  8143. C
  8144.       SUBROUTINE PGCP (K, X, Y, Z)
  8145. C
  8146. C PGPLOT (internal routine): Draw one contour segment (for use by
  8147. C PGCNSC).
  8148. C
  8149. C Arguments:
  8150. C
  8151. C K (input, integer): if K=0, move the pen to (X,Y); if K=1, draw
  8152. C       a line from the current position to (X,Y); otherwise
  8153. C       do nothing.
  8154. C X (input, real): X world-coordinate of end point.
  8155. C Y (input, real): Y world-coordinate of end point.
  8156. C Z (input, real): the value of the contour level, not used by PGCP at
  8157. C       the moment.
  8158. C
  8159. C (7-Feb-1983)
  8160. C-----------------------------------------------------------------------
  8161.       INCLUDE  'f77.PGPLOT/IN'
  8162.       INTEGER  K
  8163.       REAL     X,XX,Y,YY,Z
  8164. C
  8165.       XX = TRANS(1) + TRANS(2)*X + TRANS(3)*Y
  8166.       YY = TRANS(4) + TRANS(5)*X + TRANS(6)*Y
  8167.       IF (K.EQ.1) THEN
  8168.           CALL GRLINA(XX,YY)
  8169.       ELSE IF (K.EQ.0) THEN
  8170.           CALL GRMOVA(XX,YY)
  8171.       END IF
  8172.       END
  8173. C*PGCTAB -- install the color table to be used by PGIMAG
  8174. C%void cpgctab(const float *l, const float *r, const float *g, \
  8175. C% const float *b, int nc, float contra, float bright);
  8176. C+
  8177.       SUBROUTINE PGCTAB(L, R, G, B, NC, CONTRA, BRIGHT)
  8178.       INTEGER NC
  8179.       REAL    L(NC), R(NC), G(NC), B(NC), CONTRA, BRIGHT
  8180. C
  8181. C Use the given color table to change the color representations of
  8182. C all color indexes marked for use by PGIMAG. To change which
  8183. C color indexes are thus marked, call PGSCIR before calling PGCTAB
  8184. C or PGIMAG. On devices that can change the color representations
  8185. C of previously plotted graphics, PGCTAB will also change the colors
  8186. C of existing graphics that were plotted with the marked color
  8187. C indexes. This feature can then be combined with PGBAND to
  8188. C interactively manipulate the displayed colors of data previously
  8189. C plotted with PGIMAG.
  8190. C
  8191. C Limitations:
  8192. C  1. Some devices do not propagate color representation changes
  8193. C     to previously drawn graphics.
  8194. C  2. Some devices ignore requests to change color representations.
  8195. C  3. The appearance of specific color representations on grey-scale
  8196. C     devices is device-dependent.
  8197. C
  8198. C Arguments:
  8199. C  L      (input)  : An array of NC normalized ramp-intensity levels
  8200. C                    corresponding to the RGB primary color intensities
  8201. C                    in R(),G(),B(). Colors on the ramp are linearly
  8202. C                    interpolated from neighbouring levels.
  8203. C                    Levels must be sorted in increasing order.
  8204. C                     0.0 places a color at the beginning of the ramp.
  8205. C                     1.0 places a color at the end of the ramp.
  8206. C                    Colors outside these limits are legal, but will
  8207. C                    not be visible if CONTRA=1.0 and BRIGHT=0.5.
  8208. C  R      (input)  : An array of NC normalized red intensities.
  8209. C  G      (input)  : An array of NC normalized green intensities.
  8210. C  B      (input)  : An array of NC normalized blue intensities.
  8211. C  NC     (input)  : The number of color table entries.
  8212. C  CONTRA (input)  : The contrast of the color ramp (normally 1.0).
  8213. C  BRIGHT (input)  : Brightness at the center colorindex (normally 0.5).
  8214. C--
  8215. C  17-Sep-1994 - New routine [MCS].
  8216. C-----------------------------------------------------------------------
  8217.       INTEGER MININD, MAXIND, CI
  8218.       INTEGER NTOTAL, NSPAN
  8219.       INTEGER BELOW, ABOVE
  8220.       LOGICAL FORWRD
  8221.       REAL CA, CB, CIFRAC
  8222.       REAL LEVEL
  8223.       REAL LDIFF, LFRAC
  8224.       REAL RED, GREEN, BLUE
  8225. C
  8226. C Set the minimum absolute contrast - this prevents a divide by zero.
  8227. C
  8228.       REAL MINCTR
  8229.       PARAMETER (MINCTR = 1.0/256)
  8230. C
  8231. C No colormap entries?
  8232. C
  8233.       IF(NC .EQ. 0) RETURN
  8234. C
  8235. C Determine the range of color indexes to be used.
  8236. C
  8237.       CALL PGQCIR(MININD, MAXIND)
  8238. C
  8239. C Count the total number of color indexes to be processed.
  8240. C
  8241.       NTOTAL = MAXIND - MININD + 1
  8242. C
  8243. C No definable colors?
  8244. C
  8245.       IF(NTOTAL .LT. 1 .OR. MININD .LT. 0) RETURN
  8246. C
  8247. C Prevent a divide by zero later by ensuring that CONTRA > ABS(MINCTR).
  8248. C
  8249.       IF(ABS(CONTRA) .LT. MINCTR) THEN
  8250.         CONTRA = CONTRA + SIGN(MINCTR, CONTRA)
  8251.       END IF
  8252. C
  8253. C Translate from brightness and contrast to the normalized color index
  8254. C coordinates, CA and CB, at which to place the start and end of the
  8255. C color table.
  8256. C
  8257.       CA = 0.5 - BRIGHT / CONTRA
  8258.       CB = 0.5 + (1.0 - BRIGHT) / CONTRA
  8259. C
  8260. C Determine the number of color indexes spanned by the color table.
  8261. C
  8262.       NSPAN = INT(ABS(CB-CA) * NTOTAL)
  8263. C
  8264. C Determine the direction in which the color table should be traversed.
  8265. C
  8266.       FORWRD = CA .LE. CB
  8267. C
  8268. C Initialize the indexes at which to start searching the color table.
  8269. C
  8270. C Set the start index for traversing the table from NC to 1.
  8271. C
  8272.       BELOW = NC
  8273. C
  8274. C Set the start index for traversing the table from 1 to NC.
  8275. C
  8276.       ABOVE = 1
  8277. C
  8278. C Buffer PGPLOT commands until the color map has been completely
  8279. C installed.
  8280. C
  8281.       CALL PGBBUF
  8282. C
  8283. C Linearly interpolate the color table RGB values onto each color index.
  8284. C
  8285.       DO 1 CI=MININD, MAXIND
  8286. C
  8287. C Turn the color index into a fraction of the range MININD..MAXIND.
  8288. C
  8289.         CIFRAC = REAL(CI-MININD) / REAL(MAXIND-MININD)
  8290. C
  8291. C Determine the color table position that corresponds to color index,
  8292. C CI.
  8293. C
  8294.         IF(NSPAN .GT. 0) THEN
  8295.           LEVEL = (CIFRAC-CA) / (CB-CA)
  8296.         ELSE
  8297.           IF(CIFRAC .LE. CA) THEN
  8298.             LEVEL = 0.0
  8299.           ELSE
  8300.             LEVEL = 1.0
  8301.           END IF
  8302.         END IF
  8303. C
  8304. C Search for the indexes of the two color table entries that straddle
  8305. C LEVEL. The search algorithm assumes that values in L() are
  8306. C arranged in increasing order. This allows us to search the color table
  8307. C from the point at which the last search left off, rather than having
  8308. C to search the whole color table each time.
  8309. C
  8310.         IF(FORWRD) THEN
  8311.  2        IF(ABOVE.LE.NC .AND. L(ABOVE).LT.LEVEL) THEN
  8312.             ABOVE = ABOVE + 1
  8313.             GOTO 2
  8314.           END IF
  8315.           BELOW = ABOVE - 1
  8316.         ELSE
  8317.  3        IF(BELOW.GE.1 .AND. L(BELOW).GT.LEVEL) THEN
  8318.             BELOW = BELOW - 1
  8319.             GOTO 3
  8320.           END IF
  8321.           ABOVE = BELOW + 1
  8322.         END IF
  8323. C
  8324. C If the indexes lie outside the table, substitute the index of the
  8325. C nearest edge of the table.
  8326. C
  8327.         IF(BELOW .LT. 1) THEN
  8328.           LEVEL = 0.0
  8329.           BELOW = 1
  8330.           ABOVE = 1
  8331.         ELSE IF(ABOVE .GT. NC) THEN
  8332.           LEVEL = 1.0
  8333.           BELOW = NC
  8334.           ABOVE = NC
  8335.         END IF
  8336. C
  8337. C Linearly interpolate the primary color intensities from color table
  8338. C entries, BELOW and ABOVE.
  8339. C
  8340.         LDIFF = L(ABOVE) - L(BELOW)
  8341.         IF(LDIFF .GT. MINCTR) THEN
  8342.           LFRAC = (LEVEL - L(BELOW)) / LDIFF
  8343.         ELSE
  8344.           LFRAC = 0.0
  8345.         END IF
  8346.         RED   = R(BELOW) + (R(ABOVE) - R(BELOW)) * LFRAC
  8347.         GREEN = G(BELOW) + (G(ABOVE) - G(BELOW)) * LFRAC
  8348.         BLUE  = B(BELOW) + (B(ABOVE) - B(BELOW)) * LFRAC
  8349. C
  8350. C Intensities are only defined between 0 and 1.
  8351. C
  8352.         IF(RED   .LT. 0.0)   RED = 0.0
  8353.         IF(RED   .GT. 1.0)   RED = 1.0
  8354.         IF(GREEN .LT. 0.0) GREEN = 0.0
  8355.         IF(GREEN .GT. 1.0) GREEN = 1.0
  8356.         IF(BLUE  .LT. 0.0)  BLUE = 0.0
  8357.         IF(BLUE  .GT. 1.0)  BLUE = 1.0
  8358. C
  8359. C Install the new color representation.
  8360. C
  8361.         CALL PGSCR(CI, RED, GREEN, BLUE)
  8362.  1    CONTINUE
  8363. C
  8364. C Reveal the changed color map.
  8365. C
  8366.       CALL PGEBUF
  8367.       RETURN
  8368.       END
  8369. C*PGCURS -- read cursor position
  8370. C%int cpgcurs(float *x, float *y, char *ch_scalar);
  8371. C+
  8372.       INTEGER FUNCTION PGCURS (X, Y, CH)
  8373.       REAL X, Y
  8374.       CHARACTER*(*) CH
  8375. C
  8376. C Read the cursor position and a character typed by the user.
  8377. C The position is returned in world coordinates.  PGCURS positions
  8378. C the cursor at the position specified, allows the user to move the
  8379. C cursor using the joystick or arrow keys or whatever is available on
  8380. C the device. When he has positioned the cursor, the user types a
  8381. C single character on the keyboard; PGCURS then returns this
  8382. C character and the new cursor position (in world coordinates).
  8383. C
  8384. C Returns:
  8385. C  PGCURS         : 1 if the call was successful; 0 if the device
  8386. C                    has no cursor or some other error occurs.
  8387. C Arguments:
  8388. C  X      (in/out) : the world x-coordinate of the cursor.
  8389. C  Y      (in/out) : the world y-coordinate of the cursor.
  8390. C  CH     (output) : the character typed by the user; if the device has
  8391. C                    no cursor or if some other error occurs, the value
  8392. C                    CHAR(0) [ASCII NUL character] is returned.
  8393. C
  8394. C Note: The cursor coordinates (X,Y) may be changed by PGCURS even if
  8395. C the device has no cursor or if the user does not move the cursor.
  8396. C Under these circumstances, the position returned in (X,Y) is that of
  8397. C the pixel nearest to the requested position.
  8398. C--
  8399. C  7-Sep-1994 - changed to use PGBAND [TJP].
  8400. C-----------------------------------------------------------------------
  8401.       INTEGER PGBAND
  8402.       LOGICAL PGNOTO
  8403. C
  8404.       IF (PGNOTO('PGCURS')) THEN
  8405.          CH = CHAR(0)
  8406.          PGCURS = 0
  8407.       ELSE
  8408.          PGCURS = PGBAND(0, 1, 0.0, 0.0, X, Y, CH)
  8409.       END IF
  8410.       END
  8411. C*PGCURSE -- non-standard alias for PGCURS
  8412. C+
  8413.       INTEGER FUNCTION PGCURSE (X, Y, CH)
  8414.       REAL X, Y
  8415.       CHARACTER*1 CH
  8416. C
  8417. C See description of PGCURS.
  8418. C--
  8419.       INTEGER PGCURS
  8420.       PGCURSE = PGCURS (X, Y, CH)
  8421.       END
  8422. C*PGDRAW -- draw a line from the current pen position to a point
  8423. C%void cpgdraw(float x, float y);
  8424. C+
  8425.       SUBROUTINE PGDRAW (X, Y)
  8426.       REAL X, Y
  8427. C
  8428. C Draw a line from the current pen position to the point
  8429. C with world-coordinates (X,Y). The line is clipped at the edge of the
  8430. C current window. The new pen position is (X,Y) in world coordinates.
  8431. C
  8432. C Arguments:
  8433. C  X      (input)  : world x-coordinate of the end point of the line.
  8434. C  Y      (input)  : world y-coordinate of the end point of the line.
  8435. C--
  8436. C 27-Nov-1986
  8437. C-----------------------------------------------------------------------
  8438.       CALL PGBBUF
  8439.       CALL GRLINA(X,Y)
  8440.       CALL PGEBUF
  8441.       END
  8442. C*PGEBUF -- end batch of output (buffer)
  8443. C%void cpgebuf(void);
  8444. C+
  8445.       SUBROUTINE PGEBUF
  8446. C
  8447. C A call to PGEBUF marks the end of a batch of graphical output begun
  8448. C with the last call of PGBBUF.  PGBBUF and PGEBUF calls should always
  8449. C be paired. Each call to PGBBUF increments a counter, while each call
  8450. C to PGEBUF decrements the counter. When the counter reaches 0, the
  8451. C batch of output is written on the output device.
  8452. C
  8453. C Arguments: none
  8454. C--
  8455. C 21-Nov-1985 - new routine [TJP].
  8456. C-----------------------------------------------------------------------
  8457.       INCLUDE 'f77.PGPLOT/IN'
  8458.       LOGICAL PGNOTO
  8459. C
  8460.       IF (.NOT.PGNOTO('PGEBUF')) THEN
  8461.           PGBLEV(PGID) = MAX(0, PGBLEV(PGID) - 1)
  8462.           IF (PGBLEV(PGID).EQ.0) CALL GRTERM
  8463.       END IF
  8464.       END
  8465. C*PGEND -- terminate PGPLOT
  8466. C%void cpgend(void);
  8467. C+
  8468.       SUBROUTINE PGEND
  8469. C
  8470. C Terminate PGPLOT, close and release any open graphics devices.
  8471. C If the call to PGEND is omitted, some or all of any open plots
  8472. C may be lost.
  8473. C
  8474. C Arguments: none
  8475. C--
  8476. C 22-Dec-1995 - revised to call PGCLOS for each open device.
  8477. C-----------------------------------------------------------------------
  8478.       INCLUDE 'f77.PGPLOT/IN'
  8479.       INTEGER I
  8480. C
  8481.       DO 10 I=1,PGMAXD
  8482.          IF (PGDEVS(I).EQ.1) THEN
  8483.             CALL PGSLCT(I)
  8484.             CALL PGCLOS
  8485.          END IF
  8486.  10   CONTINUE
  8487.       END
  8488. C*PGENV -- set window and viewport and draw labeled frame
  8489. C%void cpgenv(float xmin, float xmax, float ymin, float ymax, \
  8490. C% int just, int axis);
  8491. C+
  8492.       SUBROUTINE PGENV (XMIN, XMAX, YMIN, YMAX, JUST, AXIS)
  8493.       REAL XMIN, XMAX, YMIN, YMAX
  8494.       INTEGER JUST, AXIS
  8495. C
  8496. C Set PGPLOT "Plotter Environment".  PGENV establishes the scaling
  8497. C for subsequent calls to PGPT, PGLINE, etc.  The plotter is
  8498. C advanced to a new page or panel, clearing the screen if necessary.
  8499. C If the "prompt state" is ON (see PGASK), confirmation
  8500. C is requested from the user before clearing the screen.
  8501. C If requested, a box, axes, labels, etc. are drawn according to
  8502. C the setting of argument AXIS.
  8503. C
  8504. C Arguments:
  8505. C  XMIN   (input)  : the world x-coordinate at the bottom left corner
  8506. C                    of the viewport.
  8507. C  XMAX   (input)  : the world x-coordinate at the top right corner
  8508. C                    of the viewport (note XMAX may be less than XMIN).
  8509. C  YMIN   (input)  : the world y-coordinate at the bottom left corner
  8510. C                    of the viewport.
  8511. C  YMAX   (input)  : the world y-coordinate at the top right corner
  8512. C                    of the viewport (note YMAX may be less than YMIN).
  8513. C  JUST   (input)  : if JUST=1, the scales of the x and y axes (in
  8514. C                    world coordinates per inch) will be equal,
  8515. C                    otherwise they will be scaled independently.
  8516. C  AXIS   (input)  : controls the plotting of axes, tick marks, etc:
  8517. C      AXIS = -2 : draw no box, axes or labels;
  8518. C      AXIS = -1 : draw box only;
  8519. C      AXIS =  0 : draw box and label it with coordinates;
  8520. C      AXIS =  1 : same as AXIS=0, but also draw the
  8521. C                  coordinate axes (X=0, Y=0);
  8522. C      AXIS =  2 : same as AXIS=1, but also draw grid lines
  8523. C                  at major increments of the coordinates;
  8524. C      AXIS = 10 : draw box and label X-axis logarithmically;
  8525. C      AXIS = 20 : draw box and label Y-axis logarithmically;
  8526. C      AXIS = 30 : draw box and label both axes logarithmically.
  8527. C
  8528. C For other axis options, use routine PGBOX. PGENV can be persuaded to
  8529. C call PGBOX with additional axis options by defining an environment
  8530. C parameter PGPLOT_ENVOPT containing the required option codes. 
  8531. C Examples:
  8532. C   PGPLOT_ENVOPT=P      ! draw Projecting tick marks
  8533. C   PGPLOT_ENVOPT=I      ! Invert the tick marks
  8534. C   PGPLOT_ENVOPT=IV     ! Invert tick marks and label y Vertically
  8535. C--
  8536. C  1-May-1983
  8537. C 25-Sep-1985 [TJP] - change to use PGWNAD.
  8538. C 23-Nov-1985 [TJP] - add PGPLOT_ENVOPT option.
  8539. C 31-Dec-1985 [TJP] - remove automatic PGBEG call.
  8540. C 29-Aug-1989 [TJP] - remove common block; no longer needed.
  8541. C-----------------------------------------------------------------------
  8542.       INTEGER      L
  8543.       LOGICAL      PGNOTO
  8544.       CHARACTER*10 XOPTS, YOPTS, ENVOPT, TEMP
  8545. C
  8546.       IF (PGNOTO('PGENV')) RETURN
  8547. C
  8548. C Start a new picture: move to a new panel or page as necessary.
  8549. C
  8550.       CALL PGPAGE
  8551. C
  8552. C Redefine the standard viewport.
  8553. C
  8554.       CALL PGVSTD
  8555. C
  8556. C If invalid arguments are specified, issue warning and leave window
  8557. C unchanged.
  8558. C
  8559.       IF (XMIN.EQ.XMAX) THEN
  8560.           CALL GRWARN('invalid x limits in PGENV: XMIN = XMAX.')
  8561.           RETURN
  8562.       ELSE IF (YMIN.EQ.YMAX) THEN
  8563.           CALL GRWARN('invalid y limits in PGENV: YMIN = YMAX.')
  8564.           RETURN
  8565.       END IF
  8566. C
  8567. C Call PGSWIN to define the window.
  8568. C If equal-scales requested, adjust viewport.
  8569. C
  8570.       IF (JUST.EQ.1) THEN
  8571.           CALL PGWNAD(XMIN,XMAX,YMIN,YMAX)
  8572.       ELSE
  8573.           CALL PGSWIN(XMIN,XMAX,YMIN,YMAX)
  8574.       END IF
  8575. C
  8576. C Call PGBOX to draw and label frame around viewport.
  8577. C
  8578.       YOPTS = '*'
  8579.       IF (AXIS.EQ.-2) THEN
  8580.           XOPTS = ' '
  8581.       ELSE IF (AXIS.EQ.-1) THEN
  8582.           XOPTS = 'BC'
  8583.       ELSE IF (AXIS.EQ.0) THEN
  8584.           XOPTS = 'BCNST'
  8585.       ELSE IF (AXIS.EQ.1) THEN
  8586.           XOPTS = 'ABCNST'
  8587.       ELSE IF (AXIS.EQ.2) THEN
  8588.           XOPTS = 'ABCGNST'
  8589.       ELSE IF (AXIS.EQ.10) THEN
  8590.           XOPTS = 'BCNSTL'
  8591.           YOPTS = 'BCNST'
  8592.       ELSE IF (AXIS.EQ.20) THEN
  8593.           XOPTS = 'BCNST'
  8594.           YOPTS = 'BCNSTL'
  8595.       ELSE IF (AXIS.EQ.30) THEN
  8596.           XOPTS = 'BCNSTL'
  8597.           YOPTS = 'BCNSTL'
  8598.       ELSE
  8599.           CALL GRWARN('PGENV: illegal AXIS argument.')
  8600.           XOPTS = 'BCNST'
  8601.       END IF
  8602.       IF (YOPTS.EQ.'*') YOPTS = XOPTS
  8603. C
  8604. C Additional PGBOX options from PGPLOT_ENVOPT.
  8605. C
  8606.       CALL GRGENV('ENVOPT', ENVOPT, L)
  8607.       IF (L.GT.0 .AND. AXIS.GE.0) THEN
  8608.           TEMP = XOPTS
  8609.           XOPTS = ENVOPT(1:L)//TEMP
  8610.           TEMP = YOPTS
  8611.           YOPTS = ENVOPT(1:L)//TEMP
  8612.       END IF
  8613.       CALL PGBOX(XOPTS, 0.0, 0, YOPTS, 0.0, 0)
  8614. C
  8615.       END
  8616. C*PGERAS -- erase all graphics from current page
  8617. C%void cpgeras(void);
  8618. C+
  8619.       SUBROUTINE PGERAS
  8620. C
  8621. C Erase all graphics from the current page or panel.
  8622. C
  8623. C Arguments: none
  8624. C--
  8625. C 24-Jun-1994
  8626. C-----------------------------------------------------------------------
  8627.       INTEGER CI, FS
  8628.       REAL XV1, XV2, YV1, YV2, XW1, XW2, YW1, YW2
  8629.       CALL PGBBUF
  8630.       CALL PGQCI(CI)
  8631.       CALL PGQFS(FS)
  8632.       CALL PGSCI(0)
  8633.       CALL PGSFS(1)
  8634.       CALL PGQWIN(XW1, XW2, YW1, YW2)
  8635.       CALL PGQVP(0, XV1, XV2, YV1, YV2)
  8636.       CALL PGSVP(0.0, 1.0, 0.0, 1.0)
  8637.       CALL PGRECT(XW1, XW2, YW1, YW2)
  8638.       CALL PGSVP(XV1, XV2, YV1, YV2)
  8639.       CALL PGSCI(CI)
  8640.       CALL PGSFS(FS)
  8641.       CALL PGEBUF
  8642.       END
  8643. C*PGERRB -- horizontal or vertical error bar
  8644. C%void cpgerrb(int dir, int n, const float *x, const float *y, \
  8645. C% const float *e, float t);
  8646. C+
  8647.       SUBROUTINE PGERRB (DIR, N, X, Y, E, T)
  8648.       INTEGER DIR, N
  8649.       REAL X(*), Y(*), E(*)
  8650.       REAL T
  8651. C
  8652. C Plot error bars in the direction specified by DIR.
  8653. C This routine draws an error bar only; to mark the data point at
  8654. C the start of the error bar, an additional call to PGPT is required.
  8655. C
  8656. C Arguments:
  8657. C  DIR    (input)  : direction to plot the error bar relative to
  8658. C                    the data point. 
  8659. C                    One-sided error bar:
  8660. C                      DIR is 1 for +X (X to X+E);
  8661. C                             2 for +Y (Y to Y+E);
  8662. C                             3 for -X (X to X-E);
  8663. C                             4 for -Y (Y to Y-E).
  8664. C                    Two-sided error bar:
  8665. C                      DIR is 5 for +/-X (X-E to X+E); 
  8666. C                             6 for +/-Y (Y-E to Y+E).
  8667. C  N      (input)  : number of error bars to plot.
  8668. C  X      (input)  : world x-coordinates of the data.
  8669. C  Y      (input)  : world y-coordinates of the data.
  8670. C  E      (input)  : value of error bar distance to be added to the
  8671. C                    data position in world coordinates.
  8672. C  T      (input)  : length of terminals to be drawn at the ends
  8673. C                    of the error bar, as a multiple of the default
  8674. C                    length; if T = 0.0, no terminals will be drawn.
  8675. C
  8676. C Note: the dimension of arrays X, Y, and E must be greater
  8677. C than or equal to N. If N is 1, X, Y, and E may be scalar
  8678. C variables, or expressions.
  8679. C--
  8680. C  1-Mar-1991 - new routine [JM].
  8681. C 20-Apr-1992 - correct bug [ALF, TJP].
  8682. C 28-Mar-1995 - add options DIR = 5 or 6 [TJP].
  8683. C-----------------------------------------------------------------------
  8684.       INCLUDE  'f77.PGPLOT/IN'
  8685.       INTEGER  I
  8686.       LOGICAL  PGNOTO
  8687.       REAL     TIK, XX, YY
  8688. C
  8689.       IF (PGNOTO('PGERRB')) RETURN
  8690.       IF (N.LT.1) RETURN
  8691.       IF (DIR.LT.1 .OR. DIR.GT.6) RETURN
  8692.       CALL PGBBUF
  8693. C
  8694. C Determine terminal length.
  8695. C
  8696.       IF (MOD(DIR,2).EQ.1) THEN
  8697. C        -- horizontal error bar
  8698.          TIK = T*PGXSP(PGID)*0.15/PGYSCL(PGID)
  8699.       ELSE
  8700. C        -- vertical error bar
  8701.          TIK = T*PGXSP(PGID)*0.15/PGXSCL(PGID)
  8702.       END IF
  8703. C
  8704. C Loop through points.
  8705. C
  8706.       DO 10 I=1,N
  8707. C
  8708. C Draw terminal at starting point if required.
  8709. C
  8710.          IF (DIR.EQ.5) THEN
  8711.             XX = X(I)-E(I)
  8712.             YY = Y(I)
  8713.          ELSE IF (DIR.EQ.6) THEN
  8714.             XX = X(I)
  8715.             YY = Y(I)-E(I)
  8716.          ELSE
  8717.             XX = X(I)
  8718.             YY = Y(I)
  8719.          END IF
  8720.          IF (TIK.NE.0.0) THEN
  8721.             IF (DIR.EQ.5) THEN
  8722.                CALL GRMOVA(XX,YY-TIK)
  8723.                CALL GRLINA(XX,YY+TIK)
  8724.             ELSE IF (DIR.EQ.6) THEN
  8725.                CALL GRMOVA(XX-TIK,YY)
  8726.                CALL GRLINA(XX+TIK,YY)
  8727.             END IF
  8728.          END IF
  8729. C
  8730. C Draw the error bar itself.
  8731. C
  8732.          CALL GRMOVA(XX,YY)
  8733.          IF (DIR.EQ.1 .OR. DIR.EQ.5) THEN
  8734.             XX = X(I)+E(I)
  8735.             YY = Y(I)
  8736.          ELSE IF (DIR.EQ.2 .OR. DIR.EQ.6) THEN
  8737.             XX = X(I)
  8738.             YY = Y(I)+E(I)
  8739.          ELSE IF (DIR.EQ.3) THEN
  8740.             XX = X(I)-E(I)
  8741.             YY = Y(I)
  8742.          ELSE IF (DIR.EQ.4) THEN
  8743.             XX = X(I)
  8744.             YY = Y(I)-E(I)
  8745.          END IF
  8746.          CALL GRLINA(XX,YY)
  8747. C
  8748. C Draw terminal at end point.
  8749. C
  8750.          IF (TIK.NE.0.0) THEN
  8751.             IF (MOD(DIR,2).EQ.1) THEN
  8752.                CALL GRMOVA(XX,YY-TIK)
  8753.                CALL GRLINA(XX,YY+TIK)
  8754.             ELSE
  8755.                CALL GRMOVA(XX-TIK,YY)
  8756.                CALL GRLINA(XX+TIK,YY)
  8757.             END IF
  8758.          END IF
  8759. C
  8760.  10   CONTINUE
  8761.       CALL PGEBUF
  8762.       END
  8763. C*PGERRX -- horizontal error bar
  8764. C%void cpgerrx(int n, const float *x1, const float *x2, \
  8765. C% const float *y, float t);
  8766. C+
  8767.       SUBROUTINE PGERRX (N, X1, X2, Y, T)
  8768.       INTEGER N
  8769.       REAL X1(*), X2(*), Y(*)
  8770.       REAL T
  8771. C
  8772. C Plot horizontal error bars.
  8773. C This routine draws an error bar only; to mark the data point in
  8774. C the middle of the error bar, an additional call to PGPT or
  8775. C PGERRY is required.
  8776. C
  8777. C Arguments:
  8778. C  N      (input)  : number of error bars to plot.
  8779. C  X1     (input)  : world x-coordinates of lower end of the
  8780. C                    error bars.
  8781. C  X2     (input)  : world x-coordinates of upper end of the
  8782. C                    error bars.
  8783. C  Y      (input)  : world y-coordinates of the data.
  8784. C  T      (input)  : length of terminals to be drawn at the ends
  8785. C                    of the error bar, as a multiple of the default
  8786. C                    length; if T = 0.0, no terminals will be drawn.
  8787. C
  8788. C Note: the dimension of arrays X1, X2, and Y must be greater
  8789. C than or equal to N. If N is 1, X1, X2, and Y may be scalar
  8790. C variables, or expressions, eg:
  8791. C       CALL PGERRX(1,X-SIGMA,X+SIGMA,Y)
  8792. C--
  8793. C (6-Oct-1983)
  8794. C-----------------------------------------------------------------------
  8795.       INCLUDE  'f77.PGPLOT/IN'
  8796.       INTEGER  I
  8797.       LOGICAL  PGNOTO
  8798.       REAL     TIK
  8799. C
  8800.       IF (PGNOTO('PGERRX')) RETURN
  8801.       IF (N.LT.1) RETURN
  8802.       CALL PGBBUF
  8803. C
  8804.       TIK = T*PGXSP(PGID)*0.15/PGYSCL(PGID)
  8805.       DO 10 I=1,N
  8806.           IF (TIK.NE.0.0) THEN
  8807.               CALL GRMOVA(X1(I),Y(I)-TIK)
  8808.               CALL GRLINA(X1(I),Y(I)+TIK)
  8809.           END IF
  8810.           CALL GRMOVA(X1(I),Y(I))
  8811.           CALL GRLINA(X2(I),Y(I))
  8812.           IF (TIK.NE.0.0) THEN
  8813.               CALL GRMOVA(X2(I),Y(I)-TIK)
  8814.               CALL GRLINA(X2(I),Y(I)+TIK)
  8815.           END IF
  8816.    10 CONTINUE
  8817.       CALL PGEBUF
  8818.       END
  8819. C*PGERRY -- vertical error bar
  8820. C%void cpgerry(int n, const float *x, const float *y1, \
  8821. C% const float *y2, float t);
  8822. C+
  8823.       SUBROUTINE PGERRY (N, X, Y1, Y2, T)
  8824.       INTEGER N
  8825.       REAL X(*), Y1(*), Y2(*)
  8826.       REAL T
  8827. C
  8828. C Plot vertical error bars.
  8829. C This routine draws an error bar only; to mark the data point in
  8830. C the middle of the error bar, an additional call to PGPT or
  8831. C PGERRX is required.
  8832. C
  8833. C Arguments:
  8834. C  N      (input)  : number of error bars to plot.
  8835. C  X      (input)  : world x-coordinates of the data.
  8836. C  Y1     (input)  : world y-coordinates of top end of the
  8837. C                    error bars.
  8838. C  Y2     (input)  : world y-coordinates of bottom end of the
  8839. C                    error bars.
  8840. C  T      (input)  : length of terminals to be drawn at the ends
  8841. C                    of the error bar, as a multiple of the default
  8842. C                    length; if T = 0.0, no terminals will be drawn.
  8843. C
  8844. C Note: the dimension of arrays X, Y1, and Y2 must be greater
  8845. C than or equal to N. If N is 1, X, Y1, and Y2 may be scalar
  8846. C variables or expressions, eg:
  8847. C       CALL PGERRY(1,X,Y+SIGMA,Y-SIGMA)
  8848. C--
  8849. C (6-Oct-1983)
  8850. C-----------------------------------------------------------------------
  8851.       INCLUDE  'f77.PGPLOT/IN'
  8852.       INTEGER  I
  8853.       LOGICAL  PGNOTO
  8854.       REAL     TIK
  8855. C
  8856.       IF (PGNOTO('PGERRY')) RETURN
  8857.       IF (N.LT.1) RETURN
  8858.       CALL PGBBUF
  8859. C
  8860.       TIK = T*PGXSP(PGID)*0.15/PGXSCL(PGID)
  8861.       DO 10 I=1,N
  8862.           IF (TIK.NE.0.0) THEN
  8863.               CALL GRMOVA(X(I)-TIK,Y1(I))
  8864.               CALL GRLINA(X(I)+TIK,Y1(I))
  8865.           END IF
  8866.           CALL GRMOVA(X(I),Y1(I))
  8867.           CALL GRLINA(X(I),Y2(I))
  8868.           IF (TIK.NE.0.0) THEN
  8869.               CALL GRMOVA(X(I)-TIK,Y2(I))
  8870.               CALL GRLINA(X(I)+TIK,Y2(I))
  8871.           END IF
  8872.    10 CONTINUE
  8873.       CALL PGEBUF
  8874.       END
  8875. C*PGETXT -- erase text from graphics display
  8876. C%void cpgetxt(void);
  8877. C+
  8878.       SUBROUTINE PGETXT
  8879. C
  8880. C Some graphics terminals display text (the normal interactive dialog)
  8881. C on the same screen as graphics. This routine erases the text from the
  8882. C view surface without affecting the graphics. It does nothing on
  8883. C devices which do not display text on the graphics screen, and on
  8884. C devices which do not have this capability.
  8885. C
  8886. C Arguments:
  8887. C  None
  8888. C--
  8889. C 18-Feb-1988
  8890. C-----------------------------------------------------------------------
  8891.       CALL GRETXT
  8892.       END
  8893. C*PGFUNT -- function defined by X = F(T), Y = G(T)
  8894. C+
  8895.       SUBROUTINE PGFUNT (FX, FY, N, TMIN, TMAX, PGFLAG)
  8896.       REAL FX, FY
  8897.       EXTERNAL FX, FY
  8898.       INTEGER N
  8899.       REAL TMIN, TMAX
  8900.       INTEGER PGFLAG
  8901. C
  8902. C Draw a curve defined by parametric equations X = FX(T), Y = FY(T).
  8903. C
  8904. C Arguments:
  8905. C  FX     (external real function): supplied by the user, evaluates
  8906. C                    X-coordinate.
  8907. C  FY     (external real function): supplied by the user, evaluates
  8908. C                    Y-coordinate.
  8909. C  N      (input)  : the number of points required to define the
  8910. C                    curve. The functions FX and FY will each be
  8911. C                    called N+1 times.
  8912. C  TMIN   (input)  : the minimum value for the parameter T.
  8913. C  TMAX   (input)  : the maximum value for the parameter T.
  8914. C  PGFLAG (input)  : if PGFLAG = 1, the curve is plotted in the
  8915. C                    current window and viewport; if PGFLAG = 0,
  8916. C                    PGENV is called automatically by PGFUNT to
  8917. C                    start a new plot with automatic scaling.
  8918. C
  8919. C Note: The functions FX and FY must be declared EXTERNAL in the
  8920. C Fortran program unit that calls PGFUNT.
  8921. C--
  8922. C  5-Oct-1983
  8923. C 11-May-1990 - remove unnecessary include [TJP].
  8924. C 13-Dec-1990 - make errors non-fatal [TJP].
  8925. C-----------------------------------------------------------------------
  8926.       INTEGER MAXP
  8927.       PARAMETER (MAXP=1000)
  8928.       INTEGER  I
  8929.       REAL     X(0:MAXP), Y(0:MAXP), DT
  8930.       REAL     XMIN, XMAX, YMIN, YMAX
  8931. C
  8932.       IF (N.LT.1 .OR. N.GT.MAXP) THEN
  8933.           CALL GRWARN('PGFUNT: invalid arguments')
  8934.           RETURN
  8935.       END IF
  8936.       CALL PGBBUF
  8937. C
  8938. C Evaluate function.
  8939. C
  8940.       DT = (TMAX-TMIN)/N
  8941.       X(0) = FX(TMIN)
  8942.       Y(0) = FY(TMIN)
  8943.       XMIN = X(0)
  8944.       XMAX = X(0)
  8945.       YMIN = Y(0)
  8946.       YMAX = Y(0)
  8947.       DO 10 I=1,N
  8948.           X(I) = FX(TMIN+DT*I)
  8949.           Y(I) = FY(TMIN+DT*I)
  8950.           XMIN = MIN(XMIN,X(I))
  8951.           XMAX = MAX(XMAX,X(I))
  8952.           YMIN = MIN(YMIN,Y(I))
  8953.           YMAX = MAX(YMAX,Y(I))
  8954.    10 CONTINUE
  8955.       DT = 0.05*(XMAX-XMIN)
  8956.       IF (DT.EQ.0.0) THEN
  8957.           XMIN = XMIN - 1.0
  8958.           XMAX = XMAX + 1.0
  8959.       ELSE
  8960.           XMIN = XMIN - DT
  8961.           XMAX = XMAX + DT
  8962.       END IF
  8963.       DT = 0.05*(YMAX-YMIN)
  8964.       IF (DT.EQ.0.0) THEN
  8965.           YMIN = YMIN - 1.0
  8966.           YMAX = YMAX + 1.0
  8967.       ELSE
  8968.           YMIN = YMIN - DT
  8969.           YMAX = YMAX + DT
  8970.       END IF
  8971. C
  8972. C Define environment if necessary.
  8973. C
  8974.       IF (PGFLAG.EQ.0) CALL PGENV(XMIN,XMAX,YMIN,YMAX,0,0)
  8975. C
  8976. C Draw curve.
  8977. C
  8978.       CALL PGMOVE(X(0),Y(0))
  8979.       DO 20 I=1,N
  8980.           CALL PGDRAW(X(I),Y(I))
  8981.    20 CONTINUE
  8982. C
  8983.       CALL PGEBUF
  8984.       END
  8985. C*PGFUNX -- function defined by Y = F(X)
  8986. C+
  8987.       SUBROUTINE PGFUNX (FY, N, XMIN, XMAX, PGFLAG)
  8988.       REAL FY
  8989.       EXTERNAL FY
  8990.       INTEGER N
  8991.       REAL XMIN, XMAX
  8992.       INTEGER PGFLAG
  8993. C
  8994. C Draw a curve defined by the equation Y = FY(X), where FY is a
  8995. C user-supplied subroutine.
  8996. C
  8997. C Arguments:
  8998. C  FY     (external real function): supplied by the user, evaluates
  8999. C                    Y value at a given X-coordinate.
  9000. C  N      (input)  : the number of points required to define the
  9001. C                    curve. The function FY will be called N+1 times.
  9002. C                    If PGFLAG=0 and N is greater than 1000, 1000
  9003. C                    will be used instead.  If N is less than 1,
  9004. C                    nothing will be drawn.
  9005. C  XMIN   (input)  : the minimum value of X.
  9006. C  XMAX   (input)  : the maximum value of X.
  9007. C  PGFLAG (input)  : if PGFLAG = 1, the curve is plotted in the
  9008. C                    current window and viewport; if PGFLAG = 0,
  9009. C                    PGENV is called automatically by PGFUNX to
  9010. C                    start a new plot with X limits (XMIN, XMAX)
  9011. C                    and automatic scaling in Y.
  9012. C
  9013. C Note: The function FY must be declared EXTERNAL in the Fortran
  9014. C program unit that calls PGFUNX.  It has one argument, the
  9015. C x-coordinate at which the y value is required, e.g.
  9016. C   REAL FUNCTION FY(X)
  9017. C   REAL X
  9018. C   FY = .....
  9019. C   END
  9020. C--
  9021. C  6-Oct-1983 - TJP.
  9022. C  6-May-1985 - fix Y(0) bug - TJP.
  9023. C 11-May-1990 - remove unnecessary include - TJP.
  9024. C-----------------------------------------------------------------------
  9025.       INTEGER MAXP
  9026.       PARAMETER (MAXP=1000)
  9027.       INTEGER  I, NN
  9028.       REAL     Y(0:MAXP), DT, DY
  9029.       REAL     YMIN, YMAX
  9030. C
  9031. C Check N > 1, and find parameter increment.
  9032. C
  9033.       IF (N.LT.1) RETURN
  9034.       DT = (XMAX-XMIN)/N
  9035.       CALL PGBBUF
  9036. C
  9037. C Case 1: we do not have to find limits.
  9038. C
  9039.       IF (PGFLAG.NE.0) THEN
  9040.           CALL PGMOVE(XMIN,FY(XMIN))
  9041.           DO 10 I=1,N
  9042.               CALL PGDRAW(XMIN+I*DT,FY(XMIN+I*DT))
  9043.    10     CONTINUE
  9044. C
  9045. C Case 2: find limits and scale plot; function values must be stored
  9046. C in an array.
  9047. C
  9048.       ELSE
  9049.           NN = MIN(N,MAXP)
  9050.           Y(0) = FY(XMIN)
  9051.           YMIN = Y(0)
  9052.           YMAX = Y(0)
  9053.           DO 20 I=1,NN
  9054.               Y(I) = FY(XMIN+DT*I)
  9055.               YMIN = MIN(YMIN,Y(I))
  9056.               YMAX = MAX(YMAX,Y(I))
  9057.    20     CONTINUE
  9058.           DY = 0.05*(YMAX-YMIN)
  9059.           IF (DY.EQ.0.0) THEN
  9060.               YMIN = YMIN - 1.0
  9061.               YMAX = YMAX + 1.0
  9062.           ELSE
  9063.               YMIN = YMIN - DY
  9064.               YMAX = YMAX + DY
  9065.           END IF
  9066.           CALL PGENV(XMIN,XMAX,YMIN,YMAX,0,0)
  9067.           CALL PGMOVE(XMIN,Y(0))
  9068.           DO 30 I=1,NN
  9069.               CALL PGDRAW(XMIN+DT*I,Y(I))
  9070.    30     CONTINUE
  9071.       END IF
  9072. C
  9073.       CALL PGEBUF
  9074.       END
  9075. C*PGFUNY -- function defined by X = F(Y)
  9076. C+
  9077.       SUBROUTINE PGFUNY (FX, N, YMIN, YMAX, PGFLAG)
  9078.       REAL    FX
  9079.       EXTERNAL FX
  9080.       INTEGER N
  9081.       REAL    YMIN, YMAX
  9082.       INTEGER PGFLAG
  9083. C
  9084. C Draw a curve defined by the equation X = FX(Y), where FY is a
  9085. C user-supplied subroutine.
  9086. C
  9087. C Arguments:
  9088. C  FX     (external real function): supplied by the user, evaluates
  9089. C                    X value at a given Y-coordinate.
  9090. C  N      (input)  : the number of points required to define the
  9091. C                    curve. The function FX will be called N+1 times.
  9092. C                    If PGFLAG=0 and N is greater than 1000, 1000
  9093. C                    will be used instead.  If N is less than 1,
  9094. C                    nothing will be drawn.
  9095. C  YMIN   (input)  : the minimum value of Y.
  9096. C  YMAX   (input)  : the maximum value of Y.
  9097. C  PGFLAG (input)  : if PGFLAG = 1, the curve is plotted in the
  9098. C                    current window and viewport; if PGFLAG = 0,
  9099. C                    PGENV is called automatically by PGFUNY to
  9100. C                    start a new plot with Y limits (YMIN, YMAX)
  9101. C                    and automatic scaling in X.
  9102. C
  9103. C Note: The function FX must be declared EXTERNAL in the Fortran
  9104. C program unit that calls PGFUNY.  It has one argument, the
  9105. C y-coordinate at which the x value is required, e.g.
  9106. C   REAL FUNCTION FX(Y)
  9107. C   REAL Y
  9108. C   FX = .....
  9109. C   END
  9110. C--
  9111. C  5-Oct-1983
  9112. C 11-May-1990 - remove unnecessary include [TJP].
  9113. C 13-DEc-1990 - make errors non-fatal [TJP].
  9114. C-----------------------------------------------------------------------
  9115.       INTEGER MAXP
  9116.       PARAMETER (MAXP=1000)
  9117.       INTEGER  I
  9118.       REAL     X(0:MAXP), Y(0:MAXP), DT
  9119.       REAL     XMIN, XMAX
  9120. C
  9121.       IF (N.LT.1 .OR. N.GT.MAXP) THEN
  9122.           CALL GRWARN('PGFUNY: invalid arguments')
  9123.           RETURN
  9124.       END IF
  9125.       CALL PGBBUF
  9126. C
  9127. C Evaluate function.
  9128. C
  9129.       DT = (YMAX-YMIN)/N
  9130.       X(0) = FX(YMIN)
  9131.       Y(0) = YMIN
  9132.       XMIN = X(0)
  9133.       XMAX = X(0)
  9134.       DO 10 I=1,N
  9135.           X(I) = FX(YMIN+DT*I)
  9136.           Y(I) = YMIN + DT*I
  9137.           XMIN = MIN(XMIN,X(I))
  9138.           XMAX = MAX(XMAX,X(I))
  9139.    10 CONTINUE
  9140.       DT = 0.05*(XMAX-XMIN)
  9141.       IF (DT.EQ.0.0) THEN
  9142.           XMIN = XMIN - 1.0
  9143.           XMAX = XMAX + 1.0
  9144.       ELSE
  9145.           XMIN = XMIN - DT
  9146.           XMAX = XMAX + DT
  9147.       END IF
  9148. C
  9149. C Define environment if necessary.
  9150. C
  9151.       IF (PGFLAG.EQ.0) CALL PGENV(XMIN,XMAX,YMIN,YMAX,0,0)
  9152. C
  9153. C Draw curve.
  9154. C
  9155.       CALL PGMOVE(X(0),Y(0))
  9156.       DO 20 I=1,N
  9157.           CALL PGDRAW(X(I),Y(I))
  9158.    20 CONTINUE
  9159. C
  9160.       CALL PGEBUF
  9161.       END
  9162. C*PGGRAY -- gray-scale map of a 2D data array
  9163. C%void cpggray(const float *a, int idim, int jdim, int i1, int i2, \
  9164. C% int j1, int j2, float fg, float bg, const float *tr);
  9165. C+
  9166.       SUBROUTINE PGGRAY (A, IDIM, JDIM, I1, I2, J1, J2,
  9167.      1                   FG, BG, TR)
  9168.       INTEGER IDIM, JDIM, I1, I2, J1, J2
  9169.       REAL    A(IDIM,JDIM), FG, BG, TR(6)
  9170. C
  9171. C Draw gray-scale map of an array in current window. The subsection
  9172. C of the array A defined by indices (I1:I2, J1:J2) is mapped onto
  9173. C the view surface world-coordinate system by the transformation
  9174. C matrix TR. The resulting quadrilateral region is clipped at the edge
  9175. C of the window and shaded with the shade at each point determined
  9176. C by the corresponding array value.  The shade is a number in the
  9177. C range 0 to 1 obtained by linear interpolation between the background
  9178. C level (BG) and the foreground level (FG), i.e.,
  9179. C
  9180. C   shade = [A(i,j) - BG] / [FG - BG]
  9181. C
  9182. C The background level BG can be either less than or greater than the
  9183. C foreground level FG.  Points in the array that are outside the range
  9184. C BG to FG are assigned shade 0 or 1 as appropriate.
  9185. C
  9186. C PGGRAY uses two different algorithms, depending how many color
  9187. C indices are available in the color index range specified for images.
  9188. C (This range is set with routine PGSCIR, and the current or default
  9189. C range can be queried by calling routine PGQCIR).
  9190. C
  9191. C If 16 or more color indices are available, PGGRAY first assigns
  9192. C color representations to these color indices to give a linear ramp
  9193. C between the background color (color index 0) and the foreground color
  9194. C (color index 1), and then calls PGIMAG to draw the image using these
  9195. C color indices. In this mode, the shaded region is "opaque": every
  9196. C pixel is assigned a color.
  9197. C
  9198. C If less than 16 color indices are available, PGGRAY uses only
  9199. C color index 1, and uses  a "dithering" algorithm to fill in pixels,
  9200. C with the shade (computed as above) determining the faction of pixels
  9201. C that are filled. In this mode the shaded region is "transparent" and
  9202. C allows previously-drawn graphics to show through.
  9203. C
  9204. C The transformation matrix TR is used to calculate the world
  9205. C coordinates of the center of the "cell" that represents each
  9206. C array element. The world coordinates of the center of the cell
  9207. C corresponding to array element A(I,J) are given by:
  9208. C
  9209. C          X = TR(1) + TR(2)*I + TR(3)*J
  9210. C          Y = TR(4) + TR(5)*I + TR(6)*J
  9211. C
  9212. C Usually TR(3) and TR(5) are zero -- unless the coordinate
  9213. C transformation involves a rotation or shear.  The corners of the
  9214. C quadrilateral region that is shaded by PGGRAY are given by
  9215. C applying this transformation to (I1-0.5,J1-0.5), (I2+0.5, J2+0.5).
  9216. C
  9217. C Arguments:
  9218. C  A      (input)  : the array to be plotted.
  9219. C  IDIM   (input)  : the first dimension of array A.
  9220. C  JDIM   (input)  : the second dimension of array A.
  9221. C  I1, I2 (input)  : the inclusive range of the first index
  9222. C                    (I) to be plotted.
  9223. C  J1, J2 (input)  : the inclusive range of the second
  9224. C                    index (J) to be plotted.
  9225. C  FG     (input)  : the array value which is to appear with the
  9226. C                    foreground color (corresponding to color index 1).
  9227. C  BG     (input)  : the array value which is to appear with the
  9228. C                    background color (corresponding to color index 0).
  9229. C  TR     (input)  : transformation matrix between array grid and
  9230. C                    world coordinates.
  9231. C--
  9232. C  2-Sep-1987: remove device-dependent code to routine GRGRAY (TJP).
  9233. C  7-Jun-1988: change documentation and argument names (TJP).
  9234. C 31-May-1989: allow 1-pixel wide arrays to be plotted (TJP).
  9235. C 17-Mar-1994: pass PG scaling info to lower routines (TJP).
  9236. C 15-Sep-1994: use PGITF attribute (TJP).
  9237. C  8-Feb-1995: use color ramp based on current foreground and background
  9238. C              colors (TJP).
  9239. C  6-May-1996: allow multiple devives (TJP).
  9240. C-----------------------------------------------------------------------
  9241.       INCLUDE  'f77.PGPLOT/IN'
  9242.       REAL PA(6)
  9243.       LOGICAL PGNOTO
  9244. C
  9245. C Check inputs.
  9246. C
  9247.       IF (PGNOTO('PGGRAY')) RETURN
  9248.       IF (I1.LT.1 .OR. I2.GT.IDIM .OR. I1.GT.I2 .OR.
  9249.      1    J1.LT.1 .OR. J2.GT.JDIM .OR. J1.GT.J2) THEN
  9250.           CALL GRWARN('PGGRAY: invalid range I1:I2, J1:J2')
  9251.       ELSE IF (FG.EQ.BG) THEN
  9252.           CALL GRWARN('PGGRAY: foreground level = background level')
  9253.       ELSE
  9254. C
  9255. C Call lower-level routine to do the work.
  9256. C
  9257.           CALL PGBBUF
  9258.           CALL PGSAVE
  9259.           CALL PGSCI(1)
  9260.           PA(1) = TR(1)*PGXSCL(PGID) + PGXORG(PGID)
  9261.           PA(2) = TR(2)*PGXSCL(PGID)
  9262.           PA(3) = TR(3)*PGXSCL(PGID)
  9263.           PA(4) = TR(4)*PGYSCL(PGID) + PGYORG(PGID)
  9264.           PA(5) = TR(5)*PGYSCL(PGID)
  9265.           PA(6) = TR(6)*PGYSCL(PGID)
  9266.           CALL GRGRAY(A, IDIM, JDIM, I1, I2, J1, J2, FG, BG, PA,
  9267.      :                PGMNCI(PGID), PGMXCI(PGID), PGITF(PGID))
  9268.           CALL PGEBUF
  9269.           CALL PGUNSA
  9270.       END IF
  9271. C-----------------------------------------------------------------------
  9272.       END
  9273.  
  9274. C*PGHI2D -- cross-sections through a 2D data array
  9275. C%void cpghi2d(const float *data, int nxv, int nyv, int ix1, \
  9276. C% int ix2, int iy1, int iy2, const float *x, int ioff, float bias, \
  9277. C% Logical center, float *ylims);
  9278. C+
  9279.       SUBROUTINE PGHI2D (DATA, NXV, NYV, IX1, IX2, IY1, IY2, X, IOFF,
  9280.      1                   BIAS, CENTER, YLIMS)
  9281.       INTEGER NXV, NYV, IX1, IX2, IY1, IY2
  9282.       REAL    DATA(NXV,NYV)
  9283.       REAL    X(IX2-IX1+1), YLIMS(IX2-IX1+1)
  9284.       INTEGER IOFF
  9285.       REAL    BIAS
  9286.       LOGICAL CENTER
  9287. C
  9288. C Plot a series of cross-sections through a 2D data array.
  9289. C Each cross-section is plotted as a hidden line histogram.  The plot
  9290. C can be slanted to give a pseudo-3D effect - if this is done, the
  9291. C call to PGENV may have to be changed to allow for the increased X
  9292. C range that will be needed.
  9293. C
  9294. C Arguments:
  9295. C  DATA   (input)  : the data array to be plotted.
  9296. C  NXV    (input)  : the first dimension of DATA.
  9297. C  NYV    (input)  : the second dimension of DATA.
  9298. C  IX1    (input)
  9299. C  IX2    (input)
  9300. C  IY1    (input)
  9301. C  IY2    (input)  : PGHI2D plots a subset of the input array DATA.
  9302. C                    This subset is delimited in the first (x)
  9303. C                    dimension by IX1 and IX2 and the 2nd (y) by IY1
  9304. C                    and IY2, inclusively. Note: IY2 < IY1 is
  9305. C                    permitted, resulting in a plot with the
  9306. C                    cross-sections plotted in reverse Y order.
  9307. C                    However, IX2 must be => IX1.
  9308. C  X      (input)  : the abscissae of the bins to be plotted. That is,
  9309. C                    X(1) should be the X value for DATA(IX1,IY1), and
  9310. C                    X should have (IX2-IX1+1) elements.  The program
  9311. C                    has to assume that the X value for DATA(x,y) is
  9312. C                    the same for all y.
  9313. C  IOFF   (input)  : an offset in array elements applied to successive
  9314. C                    cross-sections to produce a slanted effect.  A
  9315. C                    plot with IOFF > 0 slants to the right, one with
  9316. C                    IOFF < 0 slants left.
  9317. C  BIAS   (input)  : a bias value applied to each successive cross-
  9318. C                    section in order to raise it above the previous
  9319. C                    cross-section.  This is in the same units as the
  9320. C                    data.
  9321. C  CENTER (input)  : if .true., the X values denote the center of the
  9322. C                    bins; if .false. the X values denote the lower
  9323. C                    edges (in X) of the bins.
  9324. C  YLIMS  (input)  : workspace.  Should be an array of at least
  9325. C                    (IX2-IX1+1) elements.
  9326. C--
  9327. C 21-Feb-1984 - Keith Shortridge.
  9328. C-----------------------------------------------------------------------
  9329.       INCLUDE 'f77.PGPLOT/IN'
  9330.       LOGICAL FIRST,PENDOW,HPLOT,VPLOT
  9331.       INTEGER IY,INC,IX,NELMX,IXPT,NOFF
  9332.       REAL CBIAS,YNWAS,XNWAS,YN,XN,VTO,VFROM,YLIMWS,YLIM
  9333.       REAL PGHIS1
  9334.       LOGICAL PGNOTO
  9335. C
  9336. C Check arguments.
  9337. C
  9338.       IF (IX1.GT.IX2) RETURN
  9339.       IF (PGNOTO('PGHI2D')) RETURN
  9340.       CALL PGBBUF
  9341. C
  9342. C Check Y order.
  9343. C
  9344.       IF (IY1.GT.IY2) THEN
  9345.          INC = -1
  9346.       ELSE
  9347.          INC = 1
  9348.       END IF
  9349. C
  9350. C Clear limits array.
  9351. C
  9352.       NELMX = IX2 - IX1 + 1
  9353.       DO 10 IX=1,NELMX
  9354.          YLIMS(IX) = PGYBLC(PGID)
  9355.  10   CONTINUE
  9356. C
  9357. C Loop through Y values.
  9358. C
  9359.       NOFF = 0
  9360.       CBIAS = 0.
  9361.       DO 200 IY=IY1,IY2,INC
  9362.          YNWAS = CBIAS
  9363.          YLIMWS = YNWAS
  9364.          XNWAS = PGHIS1(X,NELMX,CENTER,1+NOFF)
  9365.          PENDOW = .FALSE.
  9366.          FIRST = .TRUE.
  9367.          IXPT = 1
  9368. C
  9369. C Draw histogram for this Y value.
  9370. C
  9371.          DO 100 IX=IX1,IX2
  9372.             YN = DATA(IX,IY) + CBIAS
  9373.             XN = PGHIS1(X,NELMX,CENTER,IXPT+NOFF+1)
  9374.             YLIM = YLIMS(IXPT)
  9375. C
  9376. C Given X and Y old and new values, and limits, see which parts of the
  9377. C lines are to be drawn.
  9378. C
  9379.             IF (YN.GT.YLIM) THEN
  9380.                YLIMS(IXPT) = YN
  9381.                HPLOT = .TRUE.
  9382.                VPLOT = .TRUE.
  9383.                VTO = YN
  9384.                VFROM = YLIM
  9385.                IF (YNWAS.GT.YLIMWS) VFROM = YNWAS
  9386.             ELSE
  9387.                HPLOT = .FALSE.
  9388.                IF (YNWAS.GT.YLIMWS) THEN
  9389.                   VPLOT = .TRUE.
  9390.                   VFROM = YNWAS
  9391.                   VTO = YLIM
  9392.                ELSE
  9393.                   VPLOT = .FALSE.
  9394.                END IF
  9395.             END IF
  9396. C
  9397. C Plot the bin.
  9398. C
  9399.             IF (VPLOT) THEN
  9400.                IF (.NOT.PENDOW) THEN
  9401.                   IF (FIRST) THEN
  9402.                      CALL GRMOVA(XNWAS,MAX(VTO,CBIAS))
  9403.                      FIRST = .FALSE.
  9404.                   ELSE
  9405.                      CALL GRMOVA(XNWAS,VFROM)
  9406.                   END IF
  9407.                END IF
  9408.                CALL GRLINA(XNWAS,VTO)
  9409.                IF (HPLOT) THEN
  9410.                   CALL GRLINA(XN,YN)
  9411.                END IF
  9412.             END IF
  9413.             PENDOW = HPLOT
  9414.             YLIMWS = YLIM
  9415.             YNWAS = YN
  9416.             XNWAS = XN
  9417.             IXPT = IXPT + 1
  9418.  100     CONTINUE
  9419.          IF (PENDOW) CALL GRLINA(XN,MAX(YLIM,CBIAS))
  9420. C
  9421. C If any offset in operation, shift limits array to compensate for it.
  9422. C
  9423.          IF (IOFF.GT.0) THEN
  9424.             DO 110 IX=1,NELMX-IOFF
  9425.                YLIMS(IX) = YLIMS(IX+IOFF)
  9426.  110        CONTINUE
  9427.             DO 120 IX=NELMX-IOFF+1,NELMX
  9428.                YLIMS(IX) = PGYBLC(PGID)
  9429.  120        CONTINUE
  9430.          ELSE IF (IOFF.LT.0) THEN
  9431.             DO 130 IX=NELMX,1-IOFF,-1
  9432.                YLIMS(IX) = YLIMS(IX+IOFF)
  9433.  130        CONTINUE
  9434.             DO 140 IX=1,-IOFF
  9435.                YLIMS(IX) = PGYBLC(PGID)
  9436.  140        CONTINUE
  9437.          END IF
  9438.          CBIAS = CBIAS + BIAS
  9439.          NOFF = NOFF + IOFF
  9440.  200  CONTINUE
  9441. C
  9442.       CALL PGEBUF
  9443.       END
  9444.       REAL FUNCTION PGHIS1 (X, NELMX, CENTER, IXV)
  9445.       LOGICAL CENTER
  9446.       INTEGER NELMX, IXV
  9447.       REAL X(NELMX)
  9448. C
  9449. C PGPLOT Internal routine used by PGHI2D.  Calculates the X-value for
  9450. C the left hand edge of a given element of the array being plotted.
  9451. C
  9452. C Arguments -
  9453. C
  9454. C X (input, real array): abscissae of bins
  9455. C NELMX (input, integer): number of bins
  9456. C CENTER (Input, logical): if .true., X values denote the center of
  9457. C       the bin; if .false., the X values denote the lower edge (in X)
  9458. C       of the bin.
  9459. C IXV (input, integer): the bin number in question.  Note IXV may be
  9460. C       outside the range 1..NELMX, in which case an interpolated
  9461. C       value is returned.
  9462. C
  9463. C 21-Feb-1984 - Keith Shortridge.
  9464. C  6-Sep-1989 - Changes for standard Fortran-77 [TJP].
  9465. C-----------------------------------------------------------------------
  9466.       REAL XN
  9467.       INTRINSIC REAL
  9468. C
  9469.       IF (CENTER) THEN
  9470.           IF ((IXV.GT.1).AND.(IXV.LE.NELMX)) THEN
  9471.             XN = ( X(IXV-1) + X(IXV) ) * .5
  9472.           ELSE IF (IXV.LE.1) THEN
  9473.             XN = X(1) - .5 * (X(2) - X(1)) * REAL(3 - 2 * IXV)
  9474.           ELSE IF (IXV.GT.NELMX) THEN
  9475.             XN = X(NELMX) +.5*(X(NELMX)-X(NELMX-1))*
  9476.      1           REAL((IXV-NELMX)*2-1)
  9477.           END IF
  9478.       ELSE
  9479.           IF ((IXV.GE.1).AND.(IXV.LE.NELMX)) THEN
  9480.             XN = X(IXV)
  9481.           ELSE IF (IXV.LT.1) THEN
  9482.             XN = X(1) - ( X(2) - X(1) ) * REAL( 1 - IXV )
  9483.           ELSE IF (IXV.GT.NELMX) THEN
  9484.             XN = X(NELMX) + ( X(NELMX) - X(NELMX-1)) *
  9485.      1           REAL(IXV - NELMX)
  9486.           END IF
  9487.       END IF
  9488. C
  9489.       PGHIS1 = XN
  9490.       END
  9491. C*PGHIST -- histogram of unbinned data
  9492. C%void cpghist(int n, const float *data, float datmin, float datmax, \
  9493. C% int nbin, int pgflag);
  9494. C+
  9495.       SUBROUTINE PGHIST(N, DATA, DATMIN, DATMAX, NBIN, PGFLAG)
  9496.       INTEGER N
  9497.       REAL    DATA(*)
  9498.       REAL    DATMIN, DATMAX
  9499.       INTEGER NBIN, PGFLAG
  9500. C
  9501. C Draw a histogram of N values of a variable in array
  9502. C DATA(1...N) in the range DATMIN to DATMAX using NBIN bins.  Note
  9503. C that array elements which fall exactly on the boundary between
  9504. C two bins will be counted in the higher bin rather than the
  9505. C lower one; and array elements whose value is less than DATMIN or
  9506. C greater than or equal to DATMAX will not be counted at all.
  9507. C
  9508. C Arguments:
  9509. C  N      (input)  : the number of data values.
  9510. C  DATA   (input)  : the data values. Note: the dimension of array
  9511. C                    DATA must be greater than or equal to N. The
  9512. C                    first N elements of the array are used.
  9513. C  DATMIN (input)  : the minimum data value for the histogram.
  9514. C  DATMAX (input)  : the maximum data value for the histogram.
  9515. C  NBIN   (input)  : the number of bins to use: the range DATMIN to
  9516. C                    DATMAX is divided into NBIN equal bins and
  9517. C                    the number of DATA values in each bin is
  9518. C                    determined by PGHIST.  NBIN may not exceed 200.
  9519. C  PGFLAG (input)  : if PGFLAG = 1, the histogram is plotted in the
  9520. C                    current window and viewport; if PGFLAG = 0,
  9521. C                    PGENV is called automatically by PGHIST to start
  9522. C                    a new plot (the x-limits of the window will be
  9523. C                    DATMIN and DATMAX; the y-limits will be chosen
  9524. C                    automatically.
  9525. C                    IF PGFLAG = 2,3 the histogram will be in the same
  9526. C                    window and viewport but with a filled area style.
  9527. C                    If pgflag=4,5 as for pgflag = 0,1, but simple
  9528. C                    line drawn as for PGBIN
  9529. C
  9530. C--
  9531. C Side effects:
  9532. C
  9533. C The pen position is changed to (DATMAX,0.0) in world coordinates.
  9534. C--
  9535. C  6-Sep-83:
  9536. C 11-Feb-92: fill options added.
  9537. C-----------------------------------------------------------------------
  9538.       INTEGER  MAXBIN
  9539.       PARAMETER (MAXBIN=200)
  9540.       INTEGER  I, IBIN, NUM(MAXBIN), NUMMAX, JUNK
  9541.       REAL     BINSIZ, PGRND
  9542.       REAL     CUR, PREV, XLO, XHI, YLO, YHI
  9543.       LOGICAL  PGNOTO
  9544. C
  9545.       IF (N.LT.1 .OR. DATMAX.LE.DATMIN .OR. NBIN.LT.1 .OR.
  9546.      1    NBIN.GT.MAXBIN) THEN
  9547.           CALL GRWARN('PGHIST: invalid arguments')
  9548.           RETURN
  9549.       END IF
  9550.       IF (PGNOTO('PGHIST')) RETURN
  9551.       CALL PGBBUF
  9552. C
  9553. C How many values in each bin?
  9554. C
  9555.       DO 10 IBIN=1,NBIN
  9556.           NUM(IBIN) = 0
  9557.    10 CONTINUE
  9558.       DO 20 I=1,N
  9559.           IBIN = (DATA(I)-DATMIN)/(DATMAX-DATMIN)*NBIN+1
  9560.           IF (IBIN.GE.1 .AND. IBIN.LE.NBIN) NUM(IBIN) = NUM(IBIN)+1
  9561.    20 CONTINUE
  9562.       NUMMAX = 0
  9563.       DO 30 IBIN=1,NBIN
  9564.           NUMMAX = MAX(NUMMAX,NUM(IBIN))
  9565.    30 CONTINUE
  9566.       BINSIZ = (DATMAX-DATMIN)/NBIN
  9567. C
  9568. C Boundaries of plot.
  9569. C
  9570.       XLO = DATMIN
  9571.       XHI = DATMAX
  9572.       YLO = 0.0
  9573.       YHI = PGRND(1.01*NUMMAX,JUNK)
  9574. C
  9575. C Define environment if necessary.
  9576. C
  9577.       IF (MOD(PGFLAG,2).EQ.0) THEN
  9578.          CALL PGENV(XLO,XHI,YLO,YHI,0,0)
  9579.       END IF
  9580. C
  9581. C Draw Histogram.
  9582. C
  9583.       IF (PGFLAG/2.EQ.0) THEN
  9584.          PREV = 0.0
  9585.          XHI=DATMIN
  9586.          CALL GRMOVA(DATMIN,0.0)
  9587.          DO 40 IBIN=1,NBIN
  9588.             CUR = NUM(IBIN)
  9589.             XLO=XHI
  9590.             XHI = DATMIN + IBIN*BINSIZ
  9591.             IF (CUR.EQ.0.0) THEN
  9592.                CONTINUE
  9593.             ELSE IF (CUR.LE.PREV) THEN
  9594.                CALL GRMOVA(XLO,CUR)
  9595.                CALL GRLINA(XHI,CUR)
  9596.             ELSE
  9597.                CALL GRMOVA(XLO,PREV)
  9598.                CALL GRLINA(XLO,CUR)
  9599.                CALL GRLINA(XHI,CUR)
  9600.             END IF
  9601.             CALL GRLINA(XHI,0.0)
  9602.             PREV = CUR
  9603.  40      CONTINUE
  9604.       ELSE IF (PGFLAG/2.EQ.1) THEN
  9605.          PREV = 0.0
  9606.          XHI = DATMIN
  9607.          DO 50 IBIN=1,NBIN
  9608.             CUR = NUM(IBIN)
  9609.             XLO=XHI
  9610.             XHI = DATMIN + IBIN*BINSIZ
  9611.             IF (CUR.EQ.0.0) THEN
  9612.                CONTINUE
  9613.             ELSE
  9614.                CALL PGRECT(XLO,XHI,0.0,CUR)
  9615.             END IF
  9616.  50      CONTINUE
  9617.       ELSE IF (PGFLAG/2.EQ.2) THEN
  9618.          PREV = 0.0
  9619.          CALL GRMOVA(DATMIN,0.0)
  9620.          XHI=DATMIN
  9621.          DO 60 IBIN=1,NBIN
  9622.             CUR = NUM(IBIN)
  9623.             XLO = XHI
  9624.             XHI = DATMIN + IBIN*BINSIZ
  9625.             IF (CUR.EQ.0.0 .AND. PREV.EQ.0.0) THEN
  9626.                CALL GRMOVA(XHI,0.0)
  9627.             ELSE 
  9628.                CALL GRLINA(XLO,CUR)
  9629.                IF(CUR.NE.0.0) THEN
  9630.                   CALL GRLINA(XHI,CUR)
  9631.                ELSE
  9632.                   CALL GRMOVA(XHI,CUR)
  9633.                ENDIF
  9634.             END IF
  9635.             PREV = CUR
  9636.  60      CONTINUE
  9637.       END IF
  9638. C     
  9639.       CALL PGEBUF
  9640.       END
  9641. C.PGHTCH -- hatch a polygonal area (internal routine)
  9642. C.
  9643.       SUBROUTINE PGHTCH(N, X, Y, DA)
  9644.       INTEGER N
  9645.       REAL X(*), Y(*), DA
  9646. C
  9647. C Hatch a polygonal area using equi-spaced parallel lines. The lines
  9648. C are drawn using the current line attributes: line style, line width,
  9649. C and color index. Cross-hatching can be achieved by calling this
  9650. C routine twice.
  9651. C
  9652. C Limitations: the hatching will not be done correctly if the
  9653. C polygon is so complex that a hatch line intersects more than
  9654. C 32 of its sides.
  9655. C
  9656. C Arguments:
  9657. C  N      (input)  : the number of vertices of the polygonal.
  9658. C  X,Y    (input)  : the (x,y) world-coordinates of the vertices
  9659. C                    (in order).
  9660. C  DA      (input) : 0.0 for normal hatching, 90.0 for perpendicular
  9661. C                    hatching.
  9662. C--
  9663. C Reference: I.O. Angel and G. Griffith "High-resolution computer
  9664. C graphics using Fortran 77", Halsted Press, 1987.
  9665. C
  9666. C 18-Feb-1995 [TJP].
  9667. C-----------------------------------------------------------------------
  9668. C
  9669. C MAXP is the maximum number of intersections any hatch line may make 
  9670. C with the sides of the polygon.
  9671. C
  9672.       INTEGER MAXP
  9673.       PARAMETER (MAXP=32)
  9674.       INTEGER NP(MAXP), I,J, II,JJ, NMIN,NMAX, NX, NI, NNP
  9675.       REAL ANGLE, SEPN, PHASE
  9676.       REAL RMU(MAXP), DX,DY, C, CMID,CMIN,CMAX, SX,SY, EX,EY, DELTA
  9677.       REAL QX,QY, R, RMU1, RMU2, XI,YI, BX,BY
  9678.       REAL DH, XS1, XS2, YS1, YS2, XL, XR, YT, YB, DINDX, DINDY
  9679. C
  9680. C Check arguments.
  9681. C
  9682.       IF (N.LT.3) RETURN
  9683.       CALL PGQHS(ANGLE, SEPN, PHASE)
  9684.       ANGLE = ANGLE + DA
  9685.       IF (SEPN.EQ.0.0) RETURN
  9686. C
  9687. C The unit spacing is 1 percent of the smaller of the height or
  9688. C width of the view surface. The line-spacing (DH), in inches, is
  9689. C obtained by multiplying this by argument SEPN.
  9690. C
  9691.       CALL PGQVSZ(1, XS1, XS2, YS1, YS2)
  9692.       DH = SEPN*MIN(ABS(XS2-XS1),ABS(YS2-YS1))/100.0
  9693. C
  9694. C DINDX and DINDY are the scales in inches per world-coordinate unit.
  9695. C
  9696.       CALL PGQVP(1, XS1, XS2, YS1, YS2)
  9697.       CALL PGQWIN(XL, XR, YB, YT)
  9698.       IF (XR.NE.XL .AND. YT.NE.YB) THEN
  9699.          DINDX = (XS2 - XS1) / (XR - XL)
  9700.          DINDY = (YS2 - YS1) / (YT - YB)
  9701.       ELSE
  9702.          RETURN
  9703.       END IF
  9704. C
  9705. C Initialize.
  9706. C
  9707.       CALL PGBBUF
  9708. C
  9709. C The vector (SX,SY) is a vector length DH perpendicular to
  9710. C the hatching lines, which have vector (DX,DY).
  9711. C
  9712.       DX = COS(ANGLE/57.29578)
  9713.       DY = SIN(ANGLE/57.29578)
  9714.       SX = -DH*DY
  9715.       SY = DH*DX
  9716. C
  9717. C The hatch lines are labelled by a parameter C, the distance from
  9718. C the coordinate origin. Calculate CMID, the C-value of the line
  9719. C that passes through the hatching reference point (BX,BY), and
  9720. C CMIN and CMAX, the range of C-values spanned by lines that intersect
  9721. C the polygon.
  9722. C
  9723.       BX = PHASE*SX
  9724.       BY = PHASE*SY
  9725.       CMID = DX*BY - DY*BX
  9726.       CMIN = DX*Y(1)*DINDY - DY*X(1)*DINDX
  9727.       CMAX = CMIN
  9728.       DO 10 I=2,N
  9729.          C = DX*Y(I)*DINDY - DY*X(I)*DINDX
  9730.          CMIN = MIN(C,CMIN)
  9731.          CMAX = MAX(C,CMAX)
  9732.  10   CONTINUE
  9733. C
  9734. C Compute integer labels for the hatch lines; N=0 is the line
  9735. C which passes through the reference point; NMIN and NMAX define
  9736. C the range of labels for lines that intersect the polygon.
  9737. C [Note that INT truncates towards zero; we need FLOOR and CEIL
  9738. C functions.]
  9739. C
  9740.       CMIN = (CMIN-CMID)/DH
  9741.       CMAX = (CMAX-CMID)/DH
  9742.       NMIN = INT(CMIN)
  9743.       IF (REAL(NMIN).LT.CMIN) NMIN = NMIN+1
  9744.       NMAX = INT(CMAX)
  9745.       IF (REAL(NMAX).GT.CMAX) NMAX = NMAX-1
  9746. C
  9747. C Each iteration of the following loop draws one hatch line.
  9748. C
  9749.       DO 60 J=NMIN,NMAX
  9750. C
  9751. C The parametric representation of this hatch line is
  9752. C (X,Y) = (QX,QY) + RMU*(DX,DY).
  9753. C
  9754.          QX = BX + REAL(J)*SX
  9755.          QY = BY + REAL(J)*SY
  9756. C
  9757. C Find the NX intersections of this line with the edges of the polygon.
  9758. C
  9759.          NX = 0
  9760.          NI = N
  9761.          DO 20 I=1,N
  9762.             EX = (X(I) - X(NI))*DINDX
  9763.             EY = (Y(I) - Y(NI))*DINDY
  9764.             DELTA = EX*DY - EY*DX
  9765.             IF (ABS(DELTA).LT.1E-5) THEN
  9766. C                 -- lines are parallel
  9767.             ELSE
  9768. C                 -- lines intersect in (XI,YI)
  9769.                R = ((QX-X(NI)*DINDX)*DY - (QY-Y(NI)*DINDY)*DX)/DELTA
  9770.                IF (R.GT.0.0 .AND. R.LE.1.0) THEN
  9771.                   IF (NX.LT.MAXP) NX = NX+1
  9772.                   NP(NX) = NX
  9773.                   IF (ABS(DX).GT.0.5) THEN
  9774.                      XI = X(NI)*DINDX + R*EX
  9775.                      RMU(NX) = (XI-QX)/DX
  9776.                   ELSE
  9777.                      YI = Y(NI)*DINDY + R*EY
  9778.                      RMU(NX) = (YI-QY)/DY
  9779.                   END IF
  9780.                END IF
  9781.             END IF
  9782.             NI = I
  9783.  20      CONTINUE
  9784. C     
  9785. C The RMU array now contains the intersections. Sort them into order.
  9786. C
  9787.          DO 40 II=1,NX-1
  9788.             DO 30 JJ=II+1,NX
  9789.                IF (RMU(NP(II)).LT.RMU(NP(JJ))) THEN
  9790.                   NNP = NP(II)
  9791.                   NP(II) = NP(JJ)
  9792.                   NP(JJ) = NNP
  9793.                END IF
  9794.  30         CONTINUE
  9795.  40      CONTINUE
  9796. C
  9797. C Join the intersections in pairs.
  9798. C
  9799.          NI = 1
  9800. C         -- do while NI < NX
  9801.  50      IF (NI .LT. NX) THEN
  9802.             RMU1 = RMU(NP(NI))
  9803.             RMU2 = RMU(NP(NI+1))
  9804.             CALL PGMOVE((QX+RMU1*DX)/DINDX, (QY+RMU1*DY)/DINDY)
  9805.             CALL PGDRAW((QX+RMU2*DX)/DINDX, (QY+RMU2*DY)/DINDY)
  9806.             NI = NI+2
  9807.             GOTO 50
  9808.          END IF
  9809.  60   CONTINUE
  9810. C
  9811. C Tidy up.
  9812. C
  9813.       CALL PGEBUF
  9814. C
  9815.       END
  9816. C*PGIDEN -- write username, date, and time at bottom of plot
  9817. C%void cpgiden(void);
  9818. C+
  9819.       SUBROUTINE PGIDEN
  9820. C
  9821. C Write username, date, and time at bottom of plot.
  9822. C
  9823. C Arguments: none.
  9824. C--
  9825. C  9-Feb-1988
  9826. C 10-Sep-1990 : adjust position of text [TJP]
  9827. C-----------------------------------------------------------------------
  9828.       INCLUDE 'f77.PGPLOT/IN'
  9829.       INTEGER L, M, CF, CI, LW
  9830.       CHARACTER*64 TEXT
  9831.       REAL D, CH
  9832. C
  9833.       CALL PGBBUF
  9834. C
  9835. C Get information for annotation.
  9836. C
  9837.       CALL GRUSER(TEXT, L)
  9838.       TEXT(L+1:) = ' '
  9839.       CALL GRDATE(TEXT(L+2:), M)
  9840.       L = L+1+M
  9841. C
  9842. C Save current attributes.
  9843. C
  9844.       CALL PGQCF(CF)
  9845.       CALL PGQCI(CI)
  9846.       CALL PGQLW(LW)
  9847.       CALL PGQCH(CH)
  9848. C
  9849. C Change attributes and write text.
  9850. C
  9851.       CALL PGSCF(1)
  9852.       CALL PGSCI(1)
  9853.       CALL PGSLW(1)
  9854.       CALL PGSCH(0.6)
  9855.       CALL GRLEN(TEXT(1:L),D)
  9856.       CALL GRTEXT(.FALSE., 0.0, .TRUE., PGXSZ(PGID)-D-2.0,
  9857.      1            2.0+PGYSZ(PGID)/130.0, TEXT(1:L))
  9858. C
  9859. C Restore attributes.
  9860. C
  9861.       CALL PGSCF(CF)
  9862.       CALL PGSCI(CI)
  9863.       CALL PGSLW(LW)
  9864.       CALL PGSCH(CH)
  9865.       CALL PGEBUF
  9866. C
  9867.       END
  9868. C*PGIMAG -- color image from a 2D data array
  9869. C%void cpgimag(const float *a, int idim, int jdim, int i1, int i2, \
  9870. C% int j1, int j2, float a1, float a2, const float *tr);
  9871. C+
  9872.       SUBROUTINE PGIMAG (A, IDIM, JDIM, I1, I2, J1, J2,
  9873.      1                   A1, A2, TR)
  9874.       INTEGER IDIM, JDIM, I1, I2, J1, J2
  9875.       REAL    A(IDIM,JDIM), A1, A2, TR(6)
  9876. C
  9877. C Draw a color image of an array in current window. The subsection
  9878. C of the array A defined by indices (I1:I2, J1:J2) is mapped onto
  9879. C the view surface world-coordinate system by the transformation
  9880. C matrix TR. The resulting quadrilateral region is clipped at the edge
  9881. C of the window. Each element of the array is represented in the image
  9882. C by a small quadrilateral, which is filled with a color specified by
  9883. C the corresponding array value.
  9884. C
  9885. C The subroutine uses color indices in the range C1 to C2, which can
  9886. C be specified by calling PGSCIR before PGIMAG. The default values
  9887. C for C1 and C2 are device-dependent; these values can be determined by
  9888. C calling PGQCIR. Note that color representations should be assigned to
  9889. C color indices C1 to C2 by calling PGSCR before calling PGIMAG. On some
  9890. C devices (but not all), the color representation can be changed after
  9891. C the call to PGIMAG by calling PGSCR again.
  9892. C
  9893. C Array values in the range A1 to A2 are mapped on to the range of
  9894. C color indices C1 to C2, with array values <= A1 being given color
  9895. C index C1 and values >= A2 being given color index C2. The mapping
  9896. C function for intermediate array values can be specified by
  9897. C calling routine PGSITF before PGIMAG; the default is linear.
  9898. C
  9899. C On devices which have no available color indices (C1 > C2),
  9900. C PGIMAG will return without doing anything. On devices with only
  9901. C one color index (C1=C2), all array values map to the same color
  9902. C which is rather uninteresting. An image is always "opaque",
  9903. C i.e., it obscures all graphical elements previously drawn in
  9904. C the region.
  9905. C
  9906. C The transformation matrix TR is used to calculate the world
  9907. C coordinates of the center of the "cell" that represents each
  9908. C array element. The world coordinates of the center of the cell
  9909. C corresponding to array element A(I,J) are given by:
  9910. C
  9911. C          X = TR(1) + TR(2)*I + TR(3)*J
  9912. C          Y = TR(4) + TR(5)*I + TR(6)*J
  9913. C
  9914. C Usually TR(3) and TR(5) are zero -- unless the coordinate
  9915. C transformation involves a rotation or shear.  The corners of the
  9916. C quadrilateral region that is shaded by PGIMAG are given by
  9917. C applying this transformation to (I1-0.5,J1-0.5), (I2+0.5, J2+0.5).
  9918. C
  9919. C Arguments:
  9920. C  A      (input)  : the array to be plotted.
  9921. C  IDIM   (input)  : the first dimension of array A.
  9922. C  JDIM   (input)  : the second dimension of array A.
  9923. C  I1, I2 (input)  : the inclusive range of the first index
  9924. C                    (I) to be plotted.
  9925. C  J1, J2 (input)  : the inclusive range of the second
  9926. C                    index (J) to be plotted.
  9927. C  A1     (input)  : the array value which is to appear with shade C1.
  9928. C  A2     (input)  : the array value which is to appear with shade C2.
  9929. C  TR     (input)  : transformation matrix between array grid and
  9930. C                    world coordinates.
  9931. C--
  9932. C 15-Sep-1994: new routine [TJP].
  9933. C 21-Jun-1995: minor change to header comments [TJP].
  9934. C-----------------------------------------------------------------------
  9935.       INCLUDE  'f77.PGPLOT/IN'
  9936.       REAL PA(6)
  9937.       LOGICAL PGNOTO
  9938. C
  9939. C Check inputs.
  9940. C
  9941.       IF (PGNOTO('PGIMAG')) RETURN
  9942.       IF (I1.LT.1 .OR. I2.GT.IDIM .OR. I1.GT.I2 .OR.
  9943.      1    J1.LT.1 .OR. J2.GT.JDIM .OR. J1.GT.J2) THEN
  9944.           CALL GRWARN('PGIMAG: invalid range I1:I2, J1:J2')
  9945.       ELSE IF (A1.EQ.A2) THEN
  9946.           CALL GRWARN('PGIMAG: foreground level = background level')
  9947.       ELSE IF (PGMNCI(PGID).GT.PGMXCI(PGID)) THEN
  9948.           CALL GRWARN('PGIMAG: not enough colors available')
  9949.       ELSE
  9950. C
  9951. C Call lower-level routine to do the work.
  9952. C
  9953.           CALL PGBBUF
  9954.           PA(1) = TR(1)*PGXSCL(PGID) + PGXORG(PGID)
  9955.           PA(2) = TR(2)*PGXSCL(PGID)
  9956.           PA(3) = TR(3)*PGXSCL(PGID)
  9957.           PA(4) = TR(4)*PGYSCL(PGID) + PGYORG(PGID)
  9958.           PA(5) = TR(5)*PGYSCL(PGID)
  9959.           PA(6) = TR(6)*PGYSCL(PGID)
  9960.           CALL GRIMG0(A, IDIM, JDIM, I1, I2, J1, J2, A1, A2, PA,
  9961.      :                PGMNCI(PGID), PGMXCI(PGID), PGITF(PGID))
  9962.           CALL PGEBUF
  9963.       END IF
  9964. C-----------------------------------------------------------------------
  9965.       END
  9966. C PGINIT -- initialize PGPLOT (internal routine)
  9967. C
  9968.       SUBROUTINE PGINIT
  9969. C
  9970. C Initialize PGPLOT. This routine should be called once during program
  9971. C execution, before any other PGPLOT routines.
  9972. C--
  9973. C Last modified: 1996 Apr 30 [TJP].
  9974. C-----------------------------------------------------------------------
  9975.       INCLUDE 'f77.PGPLOT/IN'
  9976.       INTEGER CALLED, I
  9977.       SAVE CALLED
  9978.       DATA CALLED /0/
  9979. C
  9980.       IF (CALLED.EQ.0) THEN
  9981.          PGID = 0
  9982.          DO 10 I=1,PGMAXD
  9983.             PGDEVS(I) = 0
  9984.  10      CONTINUE
  9985.          CALL GRINIT
  9986.          CALLED = 1
  9987.       END IF
  9988. C
  9989.       RETURN
  9990.       END
  9991. C*PGLAB -- write labels for x-axis, y-axis, and top of plot
  9992. C%void cpglab(const char *xlbl, const char *ylbl, const char *toplbl);
  9993. C+
  9994.       SUBROUTINE PGLAB (XLBL, YLBL, TOPLBL)
  9995.       CHARACTER*(*) XLBL, YLBL, TOPLBL
  9996. C
  9997. C Write labels outside the viewport. This routine is a simple
  9998. C interface to PGMTXT, which should be used if PGLAB is inadequate.
  9999. C
  10000. C Arguments:
  10001. C  XLBL   (input) : a label for the x-axis (centered below the
  10002. C                   viewport).
  10003. C  YLBL   (input) : a label for the y-axis (centered to the left
  10004. C                   of the viewport, drawn vertically).
  10005. C  TOPLBL (input) : a label for the entire plot (centered above the
  10006. C                   viewport).
  10007. C--
  10008. C 11-May-1990 - remove unnecessary include - TJP.
  10009. C-----------------------------------------------------------------------
  10010.       CALL PGBBUF
  10011.       CALL PGMTXT('T', 2.0, 0.5, 0.5, TOPLBL)
  10012.       CALL PGMTXT('B', 3.2, 0.5, 0.5, XLBL)
  10013.       CALL PGMTXT('L', 2.2, 0.5, 0.5, YLBL)
  10014.       CALL PGEBUF
  10015.       END
  10016. C*PGLABEL -- non-standard alias for PGLAB
  10017. C+
  10018.       SUBROUTINE PGLABEL (XLBL, YLBL, TOPLBL)
  10019.       CHARACTER*(*) XLBL, YLBL, TOPLBL
  10020. C
  10021. C See description of PGLAB.
  10022. C--
  10023.       CALL PGLAB (XLBL, YLBL, TOPLBL)
  10024.       END
  10025. C*PGLCUR -- draw a line using the cursor
  10026. C%void cpglcur(int maxpt, int *npt, float *x, float *y);
  10027. C+
  10028.       SUBROUTINE PGLCUR (MAXPT, NPT, X, Y)
  10029.       INTEGER MAXPT, NPT
  10030.       REAL    X(*), Y(*)
  10031. C
  10032. C Interactive routine for user to enter a polyline by use of
  10033. C the cursor.  Routine allows user to Add and Delete vertices;
  10034. C vertices are joined by straight-line segments.
  10035. C
  10036. C Arguments:
  10037. C  MAXPT  (input)  : maximum number of points that may be accepted.
  10038. C  NPT    (in/out) : number of points entered; should be zero on
  10039. C                    first call.
  10040. C  X      (in/out) : array of x-coordinates (dimension at least MAXPT).
  10041. C  Y      (in/out) : array of y-coordinates (dimension at least MAXPT).
  10042. C
  10043. C Notes:
  10044. C
  10045. C (1) On return from the program, cursor points are returned in
  10046. C the order they were entered. Routine may be (re-)called with points
  10047. C already defined in X,Y (# in NPT), and they will be plotted
  10048. C first, before editing.
  10049. C
  10050. C (2) User commands: the user types single-character commands
  10051. C after positioning the cursor: the following are accepted:
  10052. C   A (Add)    - add point at current cursor location.
  10053. C   D (Delete) - delete last-entered point.
  10054. C   X (eXit)   - leave subroutine.
  10055. C--
  10056. C  5-Aug-1984 - new routine [TJP].
  10057. C 16-Jul-1988 - correct error in delete operation [TJP].
  10058. C 13-Dec-1990 - change warnings to messages [TJP].
  10059. C  3-Sep-1992 - fixed erase first point bug under Add option [JM/TJP].
  10060. C  7-Sep-1994 - use PGBAND [TJP].
  10061. C  2-Aug-1995 - remove dependence on common block [TJP].
  10062. C-----------------------------------------------------------------------
  10063.       LOGICAL  PGNOTO
  10064.       CHARACTER*1 LETTER
  10065.       INTEGER  PGBAND, I, SAVCOL, MODE
  10066.       REAL     XP, YP, XREF, YREF
  10067.       REAL     XBLC, XTRC, YBLC, YTRC
  10068. C
  10069. C Check that PGPLOT is in the correct state.
  10070. C
  10071.       IF (PGNOTO('PGLCUR')) RETURN
  10072. C
  10073. C Save current color.
  10074. C
  10075.       CALL GRQCI(SAVCOL)
  10076. C
  10077. C Put current line-segments on screen.
  10078. C
  10079.       IF (NPT.EQ.1) THEN
  10080.           CALL PGPT(1,X(1),Y(1),1)
  10081.       END IF
  10082.       IF (NPT.GT.0) THEN
  10083.           CALL GRMOVA(X(1),Y(1))
  10084.           DO 10 I=2,NPT
  10085.               CALL GRLINA(X(I),Y(I))
  10086.    10     CONTINUE
  10087.       END IF
  10088. C
  10089. C Start with the cursor in the middle of the box,
  10090. C unless lines have already been drawn.
  10091. C
  10092.       CALL PGQWIN(XBLC, XTRC, YBLC, YTRC)
  10093.       IF (NPT.GT.0) THEN
  10094.           XP = X(NPT)
  10095.           YP = Y(NPT)
  10096.       ELSE
  10097.           XP = 0.5*(XBLC+XTRC)
  10098.           YP = 0.5*(YBLC+YTRC)
  10099.       END IF
  10100. C
  10101. C Loop over cursor inputs.
  10102. C
  10103.       MODE = 0
  10104.   100 XREF = XP
  10105.       YREF = YP
  10106.       IF (PGBAND(MODE,1,XREF,YREF,XP,YP,LETTER).NE.1) RETURN
  10107.       CALL GRTOUP(LETTER,LETTER)
  10108.       MODE = 1
  10109. C
  10110. C A (ADD) command:
  10111. C
  10112.       IF (LETTER .EQ. 'A') THEN
  10113.           IF (NPT.GE.MAXPT) THEN
  10114.             CALL GRMSG('ADD ignored (too many points).')
  10115.               GOTO 100
  10116.           END IF
  10117.           NPT = NPT+1
  10118.           X(NPT) = XP
  10119.           Y(NPT) = YP
  10120.           IF (NPT.EQ.1) THEN
  10121. C           -- first point: draw a dot
  10122.             CALL GRMOVA(X(NPT),Y(NPT))
  10123.             CALL PGPT(1,X(NPT),Y(NPT),1)
  10124.           ELSE
  10125. C           -- nth point: draw from (n-1) to (n)
  10126.             CALL GRLINA(X(NPT),Y(NPT))
  10127.           END IF
  10128.           CALL GRTERM
  10129. C
  10130. C D (DELETE) command:
  10131. C
  10132.       ELSE IF (LETTER.EQ.'D') THEN
  10133.           IF (NPT.LE.0) THEN
  10134.             CALL GRMSG('DELETE ignored (there are no points left).')
  10135.             GOTO 100
  10136.           END IF
  10137.           IF (NPT.GT.1) THEN
  10138. C           -- delete nth point: erase from (n-1) to (n)
  10139.             CALL GRMOVA(X(NPT-1),Y(NPT-1))
  10140.             CALL GRSCI(0)
  10141.             CALL GRLINA(X(NPT),Y(NPT))
  10142.             CALL GRSCI(SAVCOL)
  10143.             CALL GRMOVA(X(NPT-1),Y(NPT-1))
  10144.             CALL GRTERM
  10145.           ELSE IF (NPT.EQ.1) THEN
  10146. C           -- delete first point: erase dot
  10147.             CALL GRSCI(0)
  10148.             CALL PGPT(1,X(NPT),Y(NPT),1)
  10149.             CALL GRSCI(SAVCOL)
  10150.           END IF
  10151.           NPT = NPT-1
  10152.           IF (NPT.EQ.0) THEN
  10153.             XP = 0.5*(XBLC+XTRC)
  10154.             YP = 0.5*(YBLC+YTRC)
  10155.           ELSE
  10156.             XP = X(NPT)
  10157.             YP = Y(NPT)
  10158.           END IF
  10159.           IF (NPT.EQ.1) THEN
  10160. C           -- delete 2nd point: redraw dot at first point
  10161.             CALL PGPT(1,X(1),Y(1),1)
  10162.           END IF
  10163. C
  10164. C X (EXIT) command:
  10165. C
  10166.       ELSE IF (LETTER.EQ.'X') THEN
  10167.           CALL GRETXT
  10168.           RETURN
  10169. C
  10170. C Illegal command:
  10171. C
  10172.       ELSE
  10173.           CALL GRMSG('Commands are A (add), D (delete), X (exit).')
  10174.       END IF
  10175. C
  10176.       GOTO 100
  10177.       END
  10178. C*PGLDEV -- list available device types
  10179. C%void cpgldev(void);
  10180. C+
  10181.       SUBROUTINE PGLDEV
  10182. C
  10183. C Writes a list to the terminal of all device types known to the
  10184. C current version of PGPLOT.
  10185. C
  10186. C Arguments: none.
  10187. C--
  10188. C 5-Aug-1986 - [AFT].
  10189. C 1-Aug-1988 - add version number [TJP].
  10190. C 24-Apr-1989 - add copyright notice [TJP].
  10191. C 13-Dec-1990 - changed warnings to messages [TJP].
  10192. C-----------------------------------------------------------------------
  10193.       CHARACTER*16 GVER
  10194.       INTEGER L
  10195. C
  10196.       CALL PGQINF('VERSION', GVER, L)
  10197.       CALL GRMSG('PGPLOT '//GVER(:L)//
  10198.      1           ' Copyright 1996 California Institute of Technology')
  10199.       CALL GRLDEV
  10200.       END
  10201. C*PGLEN -- find length of a string in a variety of units
  10202. C%void cpglen(int units, const char *string, float *xl, float *yl);
  10203. C+
  10204.       SUBROUTINE PGLEN (UNITS, STRING, XL, YL)
  10205.       REAL XL, YL
  10206.       INTEGER UNITS
  10207.       CHARACTER*(*) STRING
  10208. C
  10209. C Work out length of a string in x and y directions 
  10210. C
  10211. C Input
  10212. C  UNITS    :  0 => answer in normalized device coordinates
  10213. C              1 => answer in inches
  10214. C              2 => answer in mm
  10215. C              3 => answer in absolute device coordinates (dots)
  10216. C              4 => answer in world coordinates
  10217. C              5 => answer as a fraction of the current viewport size
  10218. C
  10219. C  STRING   :  String of interest
  10220. C Output
  10221. C  XL       :  Length of string in x direction
  10222. C  YL       :  Length of string in y direction
  10223. C
  10224. C--
  10225. C 15-Sep-1989 - new routine (Neil Killeen)
  10226. C-----------------------------------------------------------------------
  10227.       INCLUDE 'f77.PGPLOT/IN'
  10228.       LOGICAL PGNOTO
  10229.       REAL    D
  10230. C
  10231.       IF (PGNOTO('PGLEN')) RETURN
  10232. C
  10233. C   Work out length of a string in absolute device coordinates (dots)
  10234. C   and then convert
  10235. C
  10236.       CALL GRLEN (STRING, D)
  10237. C
  10238.       IF (UNITS.EQ.0) THEN
  10239.         XL = D / PGXSZ(PGID)
  10240.         YL = D / PGYSZ(PGID)
  10241.       ELSE IF (UNITS.EQ.1) THEN
  10242.         XL = D / PGXPIN(PGID)
  10243.         YL = D / PGYPIN(PGID)
  10244.       ELSE IF (UNITS.EQ.2) THEN
  10245.         XL = 25.4 * D / PGXPIN(PGID)
  10246.         YL = 25.4 * D / PGYPIN(PGID)
  10247.       ELSE IF (UNITS.EQ.3) THEN
  10248.         XL = D
  10249.         YL = D
  10250.       ELSE IF (UNITS.EQ.4) THEN
  10251.         XL = D / ABS(PGXSCL(PGID))
  10252.         YL = D / ABS(PGYSCL(PGID))
  10253.       ELSE IF (UNITS.EQ.5) THEN
  10254.         XL = D / PGXLEN(PGID)
  10255.         YL = D / PGYLEN(PGID)
  10256.       ELSE
  10257.         CALL GRWARN('Illegal value for UNITS in routine PGLEN')
  10258.       END IF
  10259. C
  10260.       RETURN
  10261.       END
  10262. C*PGLINE -- draw a polyline (curve defined by line-segments)
  10263. C%void cpgline(int n, const float *xpts, const float *ypts);
  10264. C+
  10265.       SUBROUTINE PGLINE (N, XPTS, YPTS)
  10266.       INTEGER  N
  10267.       REAL     XPTS(*), YPTS(*)
  10268. C
  10269. C Primitive routine to draw a Polyline. A polyline is one or more
  10270. C connected straight-line segments.  The polyline is drawn using
  10271. C the current setting of attributes color-index, line-style, and
  10272. C line-width. The polyline is clipped at the edge of the window.
  10273. C
  10274. C Arguments:
  10275. C  N      (input)  : number of points defining the line; the line
  10276. C                    consists of (N-1) straight-line segments.
  10277. C                    N should be greater than 1 (if it is 1 or less,
  10278. C                    nothing will be drawn).
  10279. C  XPTS   (input)  : world x-coordinates of the points.
  10280. C  YPTS   (input)  : world y-coordinates of the points.
  10281. C
  10282. C The dimension of arrays X and Y must be greater than or equal to N.
  10283. C The "pen position" is changed to (X(N),Y(N)) in world coordinates
  10284. C (if N > 1).
  10285. C--
  10286. C 27-Nov-1986
  10287. C-----------------------------------------------------------------------
  10288.       INTEGER  I
  10289.       LOGICAL PGNOTO
  10290. C
  10291.       IF (PGNOTO('PGLINE')) RETURN
  10292.       IF (N.LT.2) RETURN
  10293. C
  10294.       CALL PGBBUF
  10295.       CALL GRMOVA(XPTS(1),YPTS(1))
  10296.       DO 10 I=2,N
  10297.          CALL GRLINA(XPTS(I),YPTS(I))
  10298.  10   CONTINUE
  10299.       CALL PGEBUF
  10300.       END
  10301. C*PGMOVE -- move pen (change current pen position)
  10302. C%void cpgmove(float x, float y);
  10303. C+
  10304.       SUBROUTINE PGMOVE (X, Y)
  10305.       REAL X, Y
  10306. C
  10307. C Primitive routine to move the "pen" to the point with world
  10308. C coordinates (X,Y). No line is drawn.
  10309. C
  10310. C Arguments:
  10311. C  X      (input)  : world x-coordinate of the new pen position.
  10312. C  Y      (input)  : world y-coordinate of the new pen position.
  10313. C--
  10314. C (29-Dec-1983)
  10315. C-----------------------------------------------------------------------
  10316.       CALL GRMOVA(X,Y)
  10317.       END
  10318. C*PGMTEXT -- non-standard alias for PGMTXT
  10319. C+
  10320.       SUBROUTINE PGMTEXT (SIDE, DISP, COORD, FJUST, TEXT)
  10321.       CHARACTER*(*) SIDE, TEXT
  10322.       REAL DISP, COORD, FJUST
  10323. C
  10324. C See description of PGMTXT.
  10325. C--
  10326.       CALL PGMTXT (SIDE, DISP, COORD, FJUST, TEXT)
  10327.       END
  10328. C*PGMTXT -- write text at position relative to viewport
  10329. C%void cpgmtxt(const char *side, float disp, float coord, \
  10330. C% float fjust, const char *text);
  10331. C+
  10332.       SUBROUTINE PGMTXT (SIDE, DISP, COORD, FJUST, TEXT)
  10333.       CHARACTER*(*) SIDE, TEXT
  10334.       REAL DISP, COORD, FJUST
  10335. C
  10336. C Write text at a position specified relative to the viewport (outside
  10337. C or inside).  This routine is useful for annotating graphs. It is used
  10338. C by routine PGLAB.  The text is written using the current values of
  10339. C attributes color-index, line-width, character-height, and
  10340. C character-font.
  10341. C
  10342. C Arguments:
  10343. C  SIDE   (input)  : must include one of the characters 'B', 'L', 'T',
  10344. C                    or 'R' signifying the Bottom, Left, Top, or Right
  10345. C                    margin of the viewport. If it includes 'LV' or
  10346. C                    'RV', the string is written perpendicular to the
  10347. C                    frame rather than parallel to it.
  10348. C  DISP   (input)  : the displacement of the character string from the
  10349. C                    specified edge of the viewport, measured outwards
  10350. C                    from the viewport in units of the character
  10351. C                    height. Use a negative value to write inside the
  10352. C                    viewport, a positive value to write outside.
  10353. C  COORD  (input)  : the location of the character string along the
  10354. C                    specified edge of the viewport, as a fraction of
  10355. C                    the length of the edge.
  10356. C  FJUST  (input)  : controls justification of the string parallel to
  10357. C                    the specified edge of the viewport. If
  10358. C                    FJUST = 0.0, the left-hand end of the string will
  10359. C                    be placed at COORD; if JUST = 0.5, the center of
  10360. C                    the string will be placed at COORD; if JUST = 1.0,
  10361. C                    the right-hand end of the string will be placed at
  10362. C                    at COORD. Other values between 0 and 1 give inter-
  10363. C                    mediate placing, but they are not very useful.
  10364. C  TEXT   (input) :  the text string to be plotted. Trailing spaces are
  10365. C                    ignored when justifying the string, but leading
  10366. C                    spaces are significant.
  10367. C
  10368. C--
  10369. C 18-Apr-1983
  10370. C 15-Aug-1987 - fix BBUF/EBUF error.
  10371. C 27-Aug-1987 - fix justification error if XPERIN.ne.YPERIN.
  10372. C 05-Sep-1989 - change so that DISP has some effect for 'RV' and 
  10373. C               'LV' options [nebk]
  10374. C 16-Oct-1993 - erase background of opaque text.
  10375. C-----------------------------------------------------------------------
  10376.       INCLUDE 'f77.PGPLOT/IN'
  10377.       LOGICAL PGNOTO
  10378.       REAL ANGLE, D, X, Y, RATIO, XBOX(4), YBOX(4)
  10379.       INTEGER CI, I, L, GRTRIM
  10380.       CHARACTER*20 TEST
  10381. C
  10382.       IF (PGNOTO('PGMTXT')) RETURN
  10383. C
  10384.       L = GRTRIM(TEXT)
  10385.       IF (L.LT.1) RETURN
  10386.       D = 0.0
  10387.       IF (FJUST.NE.0.0) CALL GRLEN(TEXT(1:L),D)
  10388.       D = D*FJUST
  10389.       RATIO = PGYPIN(PGID)/PGXPIN(PGID)
  10390.       CALL GRTOUP(TEST,SIDE)
  10391.       IF (INDEX(TEST,'B').NE.0) THEN
  10392.           ANGLE = 0.0
  10393.           X = PGXOFF(PGID) + COORD*PGXLEN(PGID) - D
  10394.           Y = PGYOFF(PGID) - PGYSP(PGID)*DISP
  10395.       ELSE IF (INDEX(TEST,'LV').NE.0) THEN
  10396.           ANGLE = 0.0
  10397.           X = PGXOFF(PGID) - PGYSP(PGID)*DISP - D
  10398.           Y = PGYOFF(PGID) + COORD*PGYLEN(PGID) - 0.3*PGYSP(PGID)
  10399.       ELSE IF (INDEX(TEST,'L').NE.0) THEN
  10400.           ANGLE = 90.0
  10401.           X = PGXOFF(PGID) - PGYSP(PGID)*DISP
  10402.           Y = PGYOFF(PGID) + COORD*PGYLEN(PGID) - D*RATIO
  10403.       ELSE IF (INDEX(TEST,'T').NE.0) THEN
  10404.           ANGLE = 0.0
  10405.           X = PGXOFF(PGID) + COORD*PGXLEN(PGID) - D
  10406.           Y = PGYOFF(PGID) + PGYLEN(PGID) + PGYSP(PGID)*DISP
  10407.       ELSE IF (INDEX(TEST,'RV').NE.0) THEN
  10408.           ANGLE = 0.0
  10409.           X = PGXOFF(PGID) + PGXLEN(PGID) + PGYSP(PGID)*DISP - D
  10410.           Y = PGYOFF(PGID) + COORD*PGYLEN(PGID) - 0.3*PGYSP(PGID)
  10411.       ELSE IF (INDEX(TEST,'R').NE.0) THEN
  10412.           ANGLE = 90.0
  10413.           X = PGXOFF(PGID) + PGXLEN(PGID) + PGYSP(PGID)*DISP
  10414.           Y = PGYOFF(PGID) + COORD*PGYLEN(PGID) - D*RATIO
  10415.       ELSE
  10416.           CALL GRWARN('Invalid "SIDE" argument in PGMTXT.')
  10417.           RETURN
  10418.       END IF
  10419.       CALL PGBBUF
  10420.       IF (PGTBCI(PGID).GE.0) THEN
  10421.           CALL GRQTXT (ANGLE, X, Y, TEXT(1:L), XBOX, YBOX)
  10422.           DO 25 I=1,4
  10423.               XBOX(I) = (XBOX(I)-PGXORG(PGID))/PGXSCL(PGID)
  10424.               YBOX(I) = (YBOX(I)-PGYORG(PGID))/PGYSCL(PGID)
  10425.    25     CONTINUE
  10426.           CALL PGQCI(CI)
  10427.           CALL PGSCI(PGTBCI(PGID))
  10428.           CALL GRFA(4, XBOX, YBOX)
  10429.           CALL PGSCI(CI)
  10430.       END IF
  10431.       CALL GRTEXT(.FALSE.,ANGLE,.TRUE., X, Y, TEXT(1:L))
  10432.       CALL PGEBUF
  10433.       END
  10434. C*PGNCUR -- mark a set of points using the cursor
  10435. C%void cpgncur(int maxpt, int *npt, float *x, float *y, int symbol);
  10436. C+
  10437.       SUBROUTINE PGNCUR (MAXPT, NPT, X, Y, SYMBOL)
  10438.       INTEGER MAXPT, NPT
  10439.       REAL    X(*), Y(*)
  10440.       INTEGER SYMBOL
  10441. C
  10442. C Interactive routine for user to enter data points by use of
  10443. C the cursor.  Routine allows user to Add and Delete points.  The
  10444. C points are returned in order of increasing x-coordinate, not in the
  10445. C order they were entered.
  10446. C
  10447. C Arguments:
  10448. C  MAXPT  (input)  : maximum number of points that may be accepted.
  10449. C  NPT    (in/out) : number of points entered; should be zero on
  10450. C                    first call.
  10451. C  X      (in/out) : array of x-coordinates.
  10452. C  Y      (in/out) : array of y-coordinates.
  10453. C  SYMBOL (input)  : code number of symbol to use for marking
  10454. C                    entered points (see PGPT).
  10455. C
  10456. C Note (1): The dimension of arrays X and Y must be greater than or
  10457. C equal to MAXPT.
  10458. C
  10459. C Note (2): On return from the program, cursor points are returned in
  10460. C increasing order of X. Routine may be (re-)called with points
  10461. C already defined in X,Y (number in NPT), and they will be plotted
  10462. C first, before editing.
  10463. C
  10464. C Note (3): User commands: the user types single-character commands
  10465. C after positioning the cursor: the following are accepted:
  10466. C A (Add)    - add point at current cursor location.
  10467. C D (Delete) - delete nearest point to cursor.
  10468. C X (eXit)   - leave subroutine.
  10469. C--
  10470. C 27-Nov-1983
  10471. C  9-Jul-1983 - modified to use GRSCI instead of GRSETLI [TJP].
  10472. C 13-Dec-1990 - changed warnings to messages [TJP].
  10473. C  2-Aug-1995 - [TJP].
  10474. C-----------------------------------------------------------------------
  10475.       INCLUDE  'f77.PGPLOT/IN'
  10476.       CHARACTER*1 LETTER
  10477.       LOGICAL  PGNOTO
  10478.       INTEGER  PGCURS, I, J, SAVCOL
  10479.       REAL     DELTA, XP, YP, XPHYS, YPHYS
  10480.       REAL     XMIN, XIP, YIP
  10481.       REAL     XBLC, XTRC, YBLC, YTRC
  10482. C
  10483. C Check that PGPLOT is in the correct state.
  10484. C
  10485.       IF (PGNOTO('PGNCUR')) RETURN
  10486. C
  10487. C Save current color.
  10488. C
  10489.       CALL GRQCI(SAVCOL)
  10490. C
  10491. C Put current points on screen.
  10492. C
  10493.       IF (NPT.NE.0) CALL PGPT(NPT,X,Y,SYMBOL)
  10494. C
  10495. C Start with the cursor in the middle of the viewport.
  10496. C
  10497.       CALL PGQWIN(XBLC, XTRC, YBLC, YTRC)
  10498.       XP = 0.5*(XBLC+XTRC)
  10499.       YP = 0.5*(YBLC+YTRC)
  10500. C
  10501. C Loop over cursor inputs.
  10502. C
  10503.   100 IF (PGCURS(XP,YP,LETTER).NE.1) RETURN
  10504.       IF (LETTER.EQ.CHAR(0)) RETURN
  10505.       CALL GRTOUP(LETTER,LETTER)
  10506. C
  10507. C A (ADD) command:
  10508. C
  10509.       IF (LETTER .EQ. 'A') THEN
  10510.           IF (NPT.GE.MAXPT) THEN
  10511.               CALL GRMSG('ADD ignored (too many points).')
  10512.               GOTO 100
  10513.           END IF
  10514. C         ! Find what current points new point is between.
  10515.           DO 120 J=1,NPT
  10516.               IF (XP.LT.X(J)) GOTO 122
  10517.   120     CONTINUE
  10518.           J = NPT + 1
  10519. C         ! New point is beyond last current
  10520.   122     CONTINUE
  10521. C         ! J is vector location where new point should be included.
  10522.           DO 140 I=NPT,J,-1
  10523.               X(I+1) = X(I)
  10524.               Y(I+1) = Y(I)
  10525.   140     CONTINUE
  10526.           NPT = NPT + 1
  10527. C         ! Add new point to point array.
  10528.           X(J) = XP
  10529.           Y(J) = YP
  10530.           CALL PGPT(1,X(J),Y(J),SYMBOL)
  10531.           CALL GRTERM
  10532. C
  10533. C D (DELETE) command:
  10534. C
  10535.       ELSE IF (LETTER.EQ.'D') THEN
  10536.           IF (NPT.LE.0) THEN
  10537.               CALL GRMSG('DELETE ignored (there are no points left).')
  10538.               GOTO 100
  10539.           END IF
  10540.           XMIN = 1.E+08
  10541. C         ! Look for point closest in radius.
  10542. C         ! Convert cursor points to physical.
  10543.           XPHYS = PGXORG(PGID) + XP*PGXSCL(PGID)
  10544.           YPHYS = PGYORG(PGID) + YP*PGYSCL(PGID)
  10545.           DO 220 I=1,NPT
  10546. C             ! Convert array points to physical.
  10547.               XIP = PGXORG(PGID) + X(I)*PGXSCL(PGID)
  10548.               YIP = PGYORG(PGID) + Y(I)*PGYSCL(PGID)
  10549.               DELTA = SQRT( (XIP-XPHYS)**2 + (YIP-YPHYS)**2 )
  10550.               IF (DELTA.LT.XMIN) THEN
  10551.                  XMIN = DELTA
  10552.                  J = I
  10553.               END IF
  10554.   220     CONTINUE
  10555. C         ! Remove point from screen by writing in background color.
  10556.           CALL GRSCI(0)
  10557.           CALL PGPT(1,X(J),Y(J),SYMBOL)
  10558.           CALL GRSCI(SAVCOL)
  10559.           CALL GRTERM
  10560. C         ! Remove point from cursor array.
  10561.           NPT = NPT-1
  10562.           DO 240 I=J,NPT
  10563.               X(I) = X(I+1)
  10564.               Y(I) = Y(I+1)
  10565.   240     CONTINUE
  10566. C
  10567. C X (EXIT) command:
  10568. C
  10569.       ELSE IF (LETTER.EQ.'X') THEN
  10570.           CALL GRETXT
  10571.           RETURN
  10572. C
  10573. C Illegal command:
  10574. C
  10575.       ELSE
  10576.           CALL GRMSG('Commands are A (add), D (delete), X (exit).')
  10577.       END IF
  10578. C
  10579.       GOTO 100
  10580.       END
  10581. C*PGNCURSE -- non-standard alias for PGNCUR
  10582. C+
  10583.       SUBROUTINE PGNCURSE (MAXPT, NPT, X, Y, SYMBOL)
  10584.       INTEGER MAXPT, NPT
  10585.       REAL    X(*), Y(*)
  10586.       INTEGER SYMBOL
  10587. C
  10588. C See description of PGNCUR.
  10589. C--
  10590.       CALL PGNCUR (MAXPT, NPT, X, Y, SYMBOL)
  10591.       END
  10592. C
  10593.       LOGICAL FUNCTION PGNOTO (RTN)
  10594.       CHARACTER*(*) RTN
  10595. C
  10596. C PGPLOT (internal routine): Test whether a PGPLOT device is open and
  10597. C print a message if not. Usage:
  10598. C     LOGICAL PGNOTO
  10599. C     IF (PGNOTO('routine')) RETURN
  10600. C
  10601. C Arguments:
  10602. C
  10603. C RTN (input, character): routine name to be include in message.
  10604. C
  10605. C Returns:
  10606. C     .TRUE. if PGPLOT is not open.
  10607. C--
  10608. C 11-Nov-1994
  10609. C 21-Dec-1995 - revised for multiple devices.
  10610. C-----------------------------------------------------------------------
  10611.       INCLUDE  'f77.PGPLOT/IN'
  10612.       CHARACTER*80 TEXT
  10613. C
  10614.       CALL PGINIT
  10615.       PGNOTO = .FALSE.
  10616.       IF (PGID.LT.1 .OR. PGID.GT.PGMAXD) THEN
  10617.          PGNOTO = .TRUE.
  10618.          TEXT = RTN//': no graphics device has been selected'
  10619.          CALL GRWARN(TEXT)
  10620.       ELSE IF (PGDEVS(PGID).NE.1) THEN
  10621.          PGNOTO = .TRUE.
  10622.          TEXT = RTN//': selected graphics device is not open'
  10623.          CALL GRWARN(TEXT)
  10624.       END IF
  10625.       RETURN
  10626.       END
  10627.  
  10628. C
  10629. C.PGNPL -- Work out how many numerals there are in an integer
  10630. C.
  10631.       SUBROUTINE PGNPL (NMAX, N, NPL)
  10632. C
  10633.       INTEGER NMAX, N, NPL
  10634. C
  10635. C     Work out how many numerals there are in an integer for use with 
  10636. C     format statements.   
  10637. C     e.g.  N=280 => NPL=3,   N=-3 => NPL=2
  10638. C
  10639. C     Input:
  10640. C       NMAX   :   If > 0, issue a warning that N is going to
  10641. C                  exceed the format statement field size if NPL 
  10642. C                  exceeds NMAX
  10643. C       N      :   Integer of interest
  10644. C     Output:
  10645. C       NPL    :   Number of numerals
  10646. C
  10647. C-
  10648. C  20-Apr-1991 -- new routine (Neil Killeen)
  10649. C-------------------------------------------------------------------------
  10650.       IF (N.EQ.0) THEN
  10651.         NPL = 1
  10652.       ELSE
  10653.         NPL = INT(LOG10(REAL(ABS(N)))) + 1
  10654.       END IF
  10655.       IF (N.LT.0) NPL = NPL + 1
  10656. C
  10657.       IF (NMAX.GT.0 .AND. NPL.GT.NMAX) 
  10658.      *  CALL GRWARN ('PGNPL: output conversion error likely; '
  10659.      *               //'number too big for format')
  10660. C
  10661.       RETURN
  10662.       END
  10663. C*PGNUMB -- convert a number into a plottable character string
  10664. C%void cpgnumb(int mm, int pp, int form, char *string, \
  10665. C% int *string_length);
  10666. C+
  10667.       SUBROUTINE PGNUMB (MM, PP, FORM, STRING, NC)
  10668.       INTEGER MM, PP, FORM
  10669.       CHARACTER*(*) STRING
  10670.       INTEGER NC
  10671. C
  10672. C This routine converts a number into a decimal character
  10673. C representation. To avoid problems of floating-point roundoff, the
  10674. C number must be provided as an integer (MM) multiplied by a power of 10
  10675. C (10**PP).  The output string retains only significant digits of MM,
  10676. C and will be in either integer format (123), decimal format (0.0123),
  10677. C or exponential format (1.23x10**5). Standard escape sequences \u, \d 
  10678. C raise the exponent and \x is used for the multiplication sign.
  10679. C This routine is used by PGBOX to create numeric labels for a plot.
  10680. C
  10681. C Formatting rules:
  10682. C   (a) Decimal notation (FORM=1):
  10683. C       - Trailing zeros to the right of the decimal sign are
  10684. C         omitted
  10685. C       - The decimal sign is omitted if there are no digits
  10686. C         to the right of it
  10687. C       - When the decimal sign is placed before the first digit
  10688. C         of the number, a zero is placed before the decimal sign
  10689. C       - The decimal sign is a period (.)
  10690. C       - No spaces are placed between digits (ie digits are not
  10691. C         grouped in threes as they should be)
  10692. C       - A leading minus (-) is added if the number is negative
  10693. C   (b) Exponential notation (FORM=2):
  10694. C       - The exponent is adjusted to put just one (non-zero)
  10695. C         digit before the decimal sign
  10696. C       - The mantissa is formatted as in (a), unless its value is
  10697. C         1 in which case it and the multiplication sign are omitted
  10698. C       - If the power of 10 is not zero and the mantissa is not
  10699. C         zero, an exponent of the form \x10\u[-]nnn is appended,
  10700. C         where \x is a multiplication sign (cross), \u is an escape
  10701. C         sequence to raise the exponent, and as many digits nnn
  10702. C         are used as needed
  10703. C   (c) Automatic choice (FORM=0):
  10704. C         Decimal notation is used if the absolute value of the
  10705. C         number is less than 10000 or greater than or equal to
  10706. C         0.01. Otherwise exponential notation is used.
  10707. C
  10708. C Arguments:
  10709. C  MM     (input)
  10710. C  PP     (input)  : the value to be formatted is MM*10**PP.
  10711. C  FORM   (input)  : controls how the number is formatted:
  10712. C                    FORM = 0 -- use either decimal or exponential
  10713. C                    FORM = 1 -- use decimal notation
  10714. C                    FORM = 2 -- use exponential notation
  10715. C  STRING (output) : the formatted character string, left justified.
  10716. C                    If the length of STRING is insufficient, a single
  10717. C                    asterisk is returned, and NC=1.
  10718. C  NC     (output) : the number of characters used in STRING:
  10719. C                    the string to be printed is STRING(1:NC).
  10720. C--
  10721. C 23-Nov-1983
  10722. C  9-Feb-1988 [TJP] - Use temporary variable to avoid illegal character
  10723. C                     assignments; remove non-standard DO loops.
  10724. C 15-Dec-1988 [TJP] - More corrections of the same sort.
  10725. C 27-Nov-1991 [TJP] - Change code for multiplication sign.
  10726. C 23-Jun-1994 [TJP] - Partial implementation of FORM=1 and 2.
  10727. C-----------------------------------------------------------------------
  10728.       CHARACTER*1 BSLASH
  10729.       CHARACTER*2 TIMES, UP, DOWN
  10730.       CHARACTER*20 WORK, WEXP, TEMP
  10731.       INTEGER M, P, ND, I, J, K, NBP
  10732.       LOGICAL MINUS
  10733. C
  10734. C Define backslash (escape) character and escape sequences.
  10735. C
  10736.       BSLASH = CHAR(92)
  10737.       TIMES  = BSLASH//'x'
  10738.       UP     = BSLASH//'u'
  10739.       DOWN   = BSLASH//'d'
  10740. C
  10741. C Zero is always printed as "0".
  10742. C
  10743.       IF (MM.EQ.0) THEN
  10744.           STRING = '0'
  10745.           NC = 1
  10746.           RETURN
  10747.       END IF
  10748. C
  10749. C If negative, make a note of that fact.
  10750. C
  10751.       MINUS = MM.LT.0
  10752.       M = ABS(MM)
  10753.       P = PP
  10754. C
  10755. C Convert M to a left-justified digit string in WORK. As M is a
  10756. C positive integer, it cannot use more than 10 digits (2147483647).
  10757. C
  10758.       J = 10
  10759.    10 IF (M.NE.0) THEN
  10760.           K = MOD(M,10)
  10761.           M = M/10
  10762.           WORK(J:J) = CHAR(ICHAR('0')+K)
  10763.           J = J-1
  10764.        GOTO 10
  10765.       END IF
  10766.       TEMP = WORK(J+1:)
  10767.       WORK = TEMP
  10768.       ND = 10-J
  10769. C
  10770. C Remove right-hand zeros, and increment P for each one removed.
  10771. C ND is the final number of significant digits in WORK, and P the
  10772. C power of 10 to be applied. Number of digits before decimal point
  10773. C is NBP.
  10774. C
  10775.    20 IF (WORK(ND:ND).EQ.'0') THEN
  10776.           ND = ND-1
  10777.           P = P+1
  10778.        GOTO 20
  10779.       END IF
  10780.       NBP = ND+MIN(P,0)
  10781. C
  10782. C Integral numbers of 4 or less digits are formatted as such.
  10783. C
  10784.       IF ((P.GE.0) .AND. ((FORM.EQ.0 .AND. P+ND.LE.4) .OR.
  10785.      :                    (FORM.EQ.1 .AND. P+ND.LE.10))) THEN
  10786.           DO 30 I=1,P
  10787.               ND = ND+1
  10788.               WORK(ND:ND) = '0'
  10789.    30     CONTINUE
  10790.           P = 0
  10791. C
  10792. C If NBP is 4 or less, simply insert a decimal point in the right place.
  10793. C
  10794.       ELSE IF (FORM.NE.2.AND.NBP.GE.1.AND.NBP.LE.4.AND.NBP.LT.ND) THEN
  10795.           TEMP = WORK(NBP+1:ND)
  10796.           WORK(NBP+2:ND+1) = TEMP
  10797.           WORK(NBP+1:NBP+1) = '.'
  10798.           ND = ND+1
  10799.           P = 0
  10800. C
  10801. C Otherwise insert a decimal point after the first digit, and adjust P.
  10802. C
  10803.       ELSE
  10804.           P = P + ND - 1
  10805.           IF (FORM.NE.2 .AND. P.EQ.-1) THEN
  10806.               TEMP = WORK
  10807.               WORK = '0'//TEMP
  10808.               ND = ND+1
  10809.               P = 0
  10810.           ELSE IF (FORM.NE.2 .AND. P.EQ.-2) THEN
  10811.               TEMP = WORK
  10812.               WORK = '00'//TEMP
  10813.               ND = ND+2
  10814.               P = 0
  10815.           END IF
  10816.           IF (ND.GT.1) THEN
  10817.               TEMP = WORK(2:ND)
  10818.               WORK(3:ND+1) = TEMP
  10819.               WORK(2:2) = '.'
  10820.               ND = ND + 1
  10821.           END IF
  10822.       END IF
  10823. C
  10824. C Add exponent if necessary.
  10825. C
  10826.       IF (P.NE.0) THEN
  10827.           WORK(ND+1:ND+6) = TIMES//'10'//UP
  10828.           ND = ND+6
  10829.           IF (P.LT.0) THEN
  10830.               P = -P
  10831.               ND = ND+1
  10832.               WORK(ND:ND) = '-'
  10833.           END IF
  10834.           J = 10
  10835.    40     IF (P.NE.0) THEN
  10836.               K = MOD(P,10)
  10837.               P = P/10
  10838.               WEXP(J:J) = CHAR(ICHAR('0')+K)
  10839.               J = J-1
  10840.            GOTO 40
  10841.           END IF
  10842.           WORK(ND+1:) = WEXP(J+1:10)
  10843.           ND = ND+10-J
  10844.           IF (WORK(1:3).EQ.'1'//TIMES) THEN
  10845.               TEMP = WORK(4:)
  10846.               WORK = TEMP
  10847.               ND = ND-3
  10848.           END IF
  10849.           WORK(ND+1:ND+2) = DOWN
  10850.           ND = ND+2
  10851.       END IF
  10852. C
  10853. C Add minus sign if necessary and move result to output.
  10854. C
  10855.       IF (MINUS) THEN
  10856.          TEMP = WORK(1:ND)
  10857.          STRING = '-'//TEMP
  10858.          NC = ND+1
  10859.       ELSE
  10860.          STRING = WORK(1:ND)
  10861.          NC = ND
  10862.       END IF
  10863. C
  10864. C Check result fits.
  10865. C
  10866.       IF (NC.GT.LEN(STRING)) THEN
  10867.           STRING = '*'
  10868.           NC = 1
  10869.       END IF
  10870.       END
  10871. C*PGOLIN -- mark a set of points using the cursor
  10872. C%void cpgolin(int maxpt, int *npt, float *x, float *y, int symbol);
  10873. C+
  10874.       SUBROUTINE PGOLIN (MAXPT, NPT, X, Y, SYMBOL)
  10875.       INTEGER MAXPT, NPT
  10876.       REAL    X(*), Y(*)
  10877.       INTEGER SYMBOL
  10878. C
  10879. C Interactive routine for user to enter data points by use of
  10880. C the cursor.  Routine allows user to Add and Delete points.  The
  10881. C points are returned in the order that they were entered (unlike
  10882. C PGNCUR).
  10883. C
  10884. C Arguments:
  10885. C  MAXPT  (input)  : maximum number of points that may be accepted.
  10886. C  NPT    (in/out) : number of points entered; should be zero on
  10887. C                    first call.
  10888. C  X      (in/out) : array of x-coordinates.
  10889. C  Y      (in/out) : array of y-coordinates.
  10890. C  SYMBOL (input)  : code number of symbol to use for marking
  10891. C                    entered points (see PGPT).
  10892. C
  10893. C Note (1): The dimension of arrays X and Y must be greater than or
  10894. C equal to MAXPT.
  10895. C
  10896. C Note (2): On return from the program, cursor points are returned in
  10897. C the order they were entered. Routine may be (re-)called with points
  10898. C already defined in X,Y (number in NPT), and they will be plotted
  10899. C first, before editing.
  10900. C
  10901. C Note (3): User commands: the user types single-character commands
  10902. C after positioning the cursor: the following are accepted:
  10903. C A (Add)    - add point at current cursor location.
  10904. C D (Delete) - delete the last point entered.
  10905. C X (eXit)   - leave subroutine.
  10906. C--
  10907. C  4-Nov-1985 - new routine (adapted from PGNCUR) - TJP.
  10908. C 13-Dec-1990 - change warnings to messages [TJP].
  10909. C  7-Sep-1994 - use PGBAND [TJP].
  10910. C  2-Aug-1995 - remove dependence on common block [TJP].
  10911. C-----------------------------------------------------------------------
  10912.       LOGICAL  PGNOTO
  10913.       CHARACTER*1 LETTER
  10914.       INTEGER  PGBAND, SAVCOL
  10915.       REAL     XP, YP, XREF, YREF
  10916.       REAL     XBLC, XTRC, YBLC, YTRC
  10917. C
  10918. C Check that PGPLOT is in the correct state.
  10919. C
  10920.       IF (PGNOTO('PGOLIN')) RETURN
  10921. C
  10922. C Save current color.
  10923. C
  10924.       CALL GRQCI(SAVCOL)
  10925. C
  10926. C Put current points on screen.  Position cursor on last point,
  10927. C or in middle viewport if there are no current points.
  10928. C
  10929.       CALL PGQWIN(XBLC, XTRC, YBLC, YTRC)
  10930.       IF (NPT.NE.0) THEN
  10931.           CALL PGPT(NPT,X,Y,SYMBOL)
  10932.           XP = X(NPT)
  10933.           YP = Y(NPT)
  10934.       ELSE
  10935.           XP = 0.5*(XBLC+XTRC)
  10936.           YP = 0.5*(YBLC+YTRC)
  10937.       END IF
  10938. C
  10939. C Loop over cursor inputs.
  10940. C
  10941.   100 XREF = XP
  10942.       YREF = YP
  10943.       IF (PGBAND(0,1,XREF,YREF,XP,YP,LETTER).NE.1) RETURN
  10944.       IF (LETTER.EQ.CHAR(0)) RETURN
  10945.       CALL GRTOUP(LETTER,LETTER)
  10946. C
  10947. C A (ADD) command:
  10948. C
  10949.       IF (LETTER .EQ. 'A') THEN
  10950.           IF (NPT.GE.MAXPT) THEN
  10951.               CALL GRMSG('ADD ignored (too many points).')
  10952.           ELSE
  10953.               NPT = NPT + 1
  10954.               X(NPT) = XP
  10955.               Y(NPT) = YP
  10956.               CALL PGPT(1,X(NPT),Y(NPT),SYMBOL)
  10957.               CALL GRTERM
  10958.           END IF
  10959. C
  10960. C D (DELETE) command:
  10961. C
  10962.       ELSE IF (LETTER.EQ.'D') THEN
  10963.           IF (NPT.LE.0) THEN
  10964.               CALL GRMSG('DELETE ignored (there are no points left).')
  10965.           ELSE
  10966.               CALL GRSCI(0)
  10967.               CALL PGPT(1,X(NPT),Y(NPT),SYMBOL)
  10968.               XP = X(NPT)
  10969.               YP = Y(NPT)
  10970.               CALL GRSCI(SAVCOL)
  10971.               CALL GRTERM
  10972.               NPT = NPT-1
  10973.           END IF
  10974. C
  10975. C X (EXIT) command:
  10976. C
  10977.       ELSE IF (LETTER.EQ.'X') THEN
  10978.           CALL GRETXT
  10979.           RETURN
  10980. C
  10981. C Illegal command:
  10982. C
  10983.       ELSE
  10984.           CALL GRMSG('Commands are A (add), D (delete), X (exit).')
  10985.       END IF
  10986. C
  10987.       GOTO 100
  10988.       END
  10989. C*PGOPEN -- open a graphics device
  10990. C%int cpgopen(const char *device);
  10991. C+
  10992.       INTEGER FUNCTION PGOPEN (DEVICE)
  10993.       CHARACTER*(*) DEVICE
  10994. C
  10995. C Open a graphics device for PGPLOT output. If the device is
  10996. C opened successfully, it becomes the selected device to which
  10997. C graphics output is directed until another device is selected
  10998. C with PGSLCT or the device is closed with PGCLOS.
  10999. C
  11000. C The value returned by PGOPEN should be tested to ensure that
  11001. C the device was opened successfully, e.g.,
  11002. C
  11003. C       ISTAT = PGOPEN('plot.ps/PS')
  11004. C       IF (ISTAT .LE. 0 ) STOP
  11005. C
  11006. C Note that PGOPEN must be declared INTEGER in the calling program.
  11007. C
  11008. C The DEVICE argument is a character constant or variable; its value
  11009. C should be one of the following:
  11010. C
  11011. C (1) A complete device specification of the form 'device/type' or
  11012. C     'file/type', where 'type' is one of the allowed PGPLOT device
  11013. C     types (installation-dependent) and 'device' or 'file' is the 
  11014. C     name of a graphics device or disk file appropriate for this type.
  11015. C     The 'device' or 'file' may contain '/' characters; the final
  11016. C     '/' delimits the 'type'. If necessary to avoid ambiguity,
  11017. C     the 'device' part of the string may be enclosed in double
  11018. C     quotation marks.
  11019. C (2) A device specification of the form '/type', where 'type' is one
  11020. C     of the allowed PGPLOT device types. PGPLOT supplies a default
  11021. C     file or device name appropriate for this device type.
  11022. C (3) A device specification with '/type' omitted; in this case
  11023. C     the type is taken from the environment variable PGPLOT_TYPE,
  11024. C     if defined (e.g., setenv PGPLOT_TYPE PS). Because of possible
  11025. C     confusion with '/' in file-names, omitting the device type
  11026. C     in this way is not recommended.
  11027. C (4) A blank string (' '); in this case, PGOPEN will use the value
  11028. C     of environment variable PGPLOT_DEV as the device specification,
  11029. C     or '/NULL' if the environment variable is undefined.
  11030. C (5) A single question mark, with optional trailing spaces ('?'); in
  11031. C     this case, PGPLOT will prompt the user to supply the device
  11032. C     specification, with a prompt string of the form
  11033. C         'Graphics device/type (? to see list, default XXX):'
  11034. C     where 'XXX' is the default (value of environment variable
  11035. C     PGPLOT_DEV).
  11036. C (6) A non-blank string in which the first character is a question
  11037. C     mark (e.g., '?Device: '); in this case, PGPLOT will prompt the
  11038. C     user to supply the device specification, using the supplied
  11039. C     string as the prompt (without the leading question mark but
  11040. C     including any trailing spaces).
  11041. C
  11042. C In cases (5) and (6), the device specification is read from the
  11043. C standard input. The user should respond to the prompt with a device
  11044. C specification of the form (1), (2), or (3). If the user types a 
  11045. C question-mark in response to the prompt, a list of available device
  11046. C types is displayed and the prompt is re-issued. If the user supplies
  11047. C an invalid device specification, the prompt is re-issued. If the user
  11048. C responds with an end-of-file character, e.g., ctrl-D in UNIX, program
  11049. C execution is aborted; this  avoids the possibility of an infinite
  11050. C prompting loop.  A programmer should avoid use of PGPLOT-prompting
  11051. C if this behavior is not desirable.
  11052. C
  11053. C The device type is case-insensitive (e.g., '/ps' and '/PS' are 
  11054. C equivalent). The device or file name may be case-sensitive in some
  11055. C operating systems.
  11056. C
  11057. C Examples of valid DEVICE arguments:
  11058. C
  11059. C (1)  'plot.ps/ps', 'dir/plot.ps/ps', '"dir/plot.ps"/ps', 
  11060. C      'user:[tjp.plots]plot.ps/PS'
  11061. C (2)  '/ps'      (PGPLOT interprets this as 'pgplot.ps/ps')
  11062. C (3)  'plot.ps'  (if PGPLOT_TYPE is defined as 'ps', PGPLOT
  11063. C                  interprets this as 'plot.ps/ps')
  11064. C (4)  '   '      (if PGPLOT_DEV is defined)
  11065. C (5)  '?  '
  11066. C (6)  '?Device specification for PGPLOT: '
  11067. C
  11068. C [This routine was added to PGPLOT in Version 5.1.0. Older programs
  11069. C use PGBEG instead.]
  11070. C
  11071. C Returns:
  11072. C  PGOPEN          : returns either a positive value, the
  11073. C                    identifier of the graphics device for use with
  11074. C                    PGSLCT, or a 0 or negative value indicating an
  11075. C                    error. In the event of error a message is
  11076. C                    written on the standard error unit.
  11077. C Arguments:
  11078. C  DEVICE  (input) : the 'device specification' for the plot device
  11079. C                    (see above).
  11080. C--
  11081. C 22-Dec-1995 - new routine [TJP].
  11082. C 14-May-1996 - device '? ' should not give a blank prompt [TJP].
  11083. C-----------------------------------------------------------------------
  11084.       INCLUDE       'f77.PGPLOT/IN'
  11085.       INTEGER       DEFTYP,GRDTYP,GROPEN,L,LR,IC1, LPROMP
  11086.       INTEGER       GRGCOM, IER, LDEFDE, UNIT, ISTAT
  11087.       REAL          DUMMY,DUMMY2,XCSZ, XSZ, YSZ
  11088.       CHARACTER*128 DEFDEV, PROMPT
  11089.       CHARACTER*20  DEFSTR
  11090.       CHARACTER*256 REQ
  11091.       LOGICAL JUNK
  11092. C
  11093. C Initialize PGPLOT if necessary.
  11094. C
  11095.       CALL PGINIT
  11096. C
  11097. C Get the default device/type (environment variable PGPLOT_DEV).
  11098. C
  11099.       CALL GRGENV('DEV', DEFDEV, LDEFDE)
  11100.       IF (LDEFDE.EQ.0) THEN
  11101.          DEFDEV = '/NULL'
  11102.          LDEFDE = 5
  11103.       END IF
  11104. C
  11105. C Open the plot file; default type is given by environment variable
  11106. C PGPLOT_TYPE.
  11107. C
  11108.       CALL GRGENV('TYPE', DEFSTR, L)
  11109.       IF (L.EQ.0) THEN
  11110.           DEFTYP = 0
  11111.       ELSE
  11112.           CALL GRTOUP(DEFSTR, DEFSTR)
  11113.           DEFTYP = GRDTYP(DEFSTR(1:L))
  11114.       END IF
  11115.       IF (DEVICE.EQ.' ') THEN
  11116. C        -- Blank device string: use default device and type.
  11117.          ISTAT = GROPEN(DEFTYP,UNIT,DEFDEV(1:LDEFDE),PGID)
  11118.       ELSE IF (DEVICE(1:1).EQ.'?') THEN
  11119.          IF (DEVICE.EQ.'?') THEN
  11120. C           -- Device string is a ingle question mark: prompt user
  11121. C           -- for device/type
  11122.             PROMPT = 'Graphics device/type (? to see list, default '
  11123.      :           //DEFDEV(1:LDEFDE)//'): '
  11124.             LPROMP = LDEFDE + 48
  11125.          ELSE
  11126. C           -- Device string starts with a question mark: use it
  11127. C           -- as a prompt
  11128.             PROMPT = DEVICE(2:)
  11129.             LPROMP = LEN(DEVICE)-1
  11130.          END IF
  11131.    10    IER = GRGCOM(REQ, PROMPT(1:LPROMP), LR)
  11132.          IF (IER.NE.1) THEN
  11133.             CALL GRWARN('Error reading device specification')
  11134.             PGOPEN = -1
  11135.             RETURN
  11136.          END IF
  11137.          IF (LR.LT.1 .OR. REQ.EQ.' ') THEN
  11138.             REQ = DEFDEV(1:LDEFDE)
  11139.          ELSE IF (REQ(1:1).EQ.'?') THEN
  11140.             CALL PGLDEV
  11141.             GOTO 10
  11142.          END IF
  11143.          ISTAT = GROPEN(DEFTYP,UNIT,REQ,PGID)
  11144.          IF (ISTAT.NE.1) GOTO 10
  11145.       ELSE
  11146.           ISTAT = GROPEN(DEFTYP,UNIT,DEVICE,PGID)
  11147.       END IF
  11148. C
  11149. C Failed to open plot file?
  11150. C
  11151.       IF (ISTAT.NE.1) THEN
  11152.          PGOPEN = - 1
  11153.          RETURN
  11154.       END IF
  11155. C
  11156. C Success: determine device characteristics.
  11157. C
  11158.       IF (PGID.LT.0 .OR. PGID.GT.PGMAXD) CALL
  11159.      1       GRWARN('Something terribly wrong in PGOPEN')
  11160.       PGDEVS(PGID) = 1
  11161.       PGADVS(PGID) = 0
  11162.       PGPFIX(PGID) = .FALSE.
  11163.       CALL GRSIZE(PGID,XSZ,YSZ,DUMMY,DUMMY2,
  11164.      1            PGXPIN(PGID),PGYPIN(PGID))
  11165.       CALL GRCHSZ(PGID,XCSZ,DUMMY,PGXSP(PGID),PGYSP(PGID))
  11166.       PGROWS(PGID)= .TRUE.
  11167.       PGNX(PGID)  = 1
  11168.       PGNY(PGID)  = 1
  11169.       PGXSZ(PGID) = XSZ
  11170.       PGYSZ(PGID) = YSZ
  11171.       PGNXC(PGID) = 1
  11172.       PGNYC(PGID) = 1
  11173.       CALL GRQTYP(DEFSTR,JUNK)
  11174. C
  11175. C Set the prompt state to ON, so that terminal devices pause between
  11176. C pages; this can be changed with PGASK.
  11177. C
  11178.       CALL PGASK(.TRUE.)
  11179. C
  11180. C If environment variable PGPLOT_BUFFER is defined (any value),
  11181. C start buffering output.
  11182. C
  11183.       PGBLEV(PGID) = 0
  11184.       CALL GRGENV('BUFFER', DEFSTR, L)
  11185.       IF (L.GT.0) CALL PGBBUF
  11186. C
  11187. C Set background and foreground colors if requested.
  11188. C
  11189.       CALL GRGENV('BACKGROUND', DEFSTR, L)
  11190.       IF (L.GT.0) CALL PGSCRN(0, DEFSTR(1:L), IER)
  11191.       CALL GRGENV('FOREGROUND', DEFSTR, L)
  11192.       IF (L.GT.0) CALL PGSCRN(1, DEFSTR(1:L), IER)
  11193. C
  11194. C Set default attributes.
  11195. C
  11196.       CALL PGSCI(1)
  11197.       CALL PGSLS(1)
  11198.       CALL PGSLW(1)
  11199.       CALL PGSCH(1.0)
  11200.       CALL PGSCF(1)
  11201.       CALL PGSFS(1)
  11202.       CALL PGSAH(1, 45.0, 0.3)
  11203.       CALL PGSTBG(-1)
  11204.       CALL PGSHS(45.0, 1.0, 0.0)
  11205. C
  11206. C Set the default range of color indices available for images (16 to
  11207. C device maximum, if device maximum >= 16; otherwise not possible).
  11208. C Select linear transfer function.
  11209. C
  11210.       CALL GRQCOL(IC1, PGMXCI(PGID))
  11211.       PGMNCI(PGID) = 16
  11212.       IF (PGMXCI(PGID).LT.16) PGMXCI(PGID) = 0
  11213.       PGITF(PGID) = 0
  11214. C
  11215. C Set the default window (unit square).
  11216. C
  11217.       PGXBLC(PGID) = 0.0
  11218.       PGXTRC(PGID) = 1.0
  11219.       PGYBLC(PGID) = 0.0
  11220.       PGYTRC(PGID) = 1.0
  11221. C
  11222. C Set the default viewport.
  11223. C
  11224.       CALL PGVSTD
  11225. C
  11226.       PGOPEN = PGID
  11227.       RETURN
  11228.       END
  11229. C*PGPAGE -- advance to new page
  11230. C%void cpgpage(void);
  11231. C+
  11232.       SUBROUTINE PGPAGE
  11233. C
  11234. C Advance plotter to a new page or panel, clearing the screen if
  11235. C necessary. If the "prompt state" is ON (see PGASK), confirmation is
  11236. C requested from the user before clearing the screen. If the view
  11237. C surface has been subdivided into panels with PGBEG or PGSUBP, then
  11238. C PGPAGE advances to the next panel, and if the current panel is the
  11239. C last on the page, PGPAGE clears the screen or starts a new sheet of
  11240. C paper.  PGPAGE does not change the PGPLOT window or the viewport
  11241. C (in normalized device coordinates); but note that if the size of the
  11242. C view-surface is changed externally (e.g., by a workstation window
  11243. C manager) the size of the viewport is chnaged in proportion.
  11244. C
  11245. C Arguments: none
  11246. C--
  11247. C  7-Feb-1983
  11248. C 23-Sep-1984 - correct bug: call GRTERM at end (if flush mode set).
  11249. C 31-Jan-1985 - make closer to Fortran-77.
  11250. C 19-Nov-1987 - explicitly clear the screen if device is interactive;
  11251. C               this restores the behavior obtained with older versions
  11252. C               of GRPCKG.
  11253. C  9-Feb-1988 - move prompting into routine GRPROM.
  11254. C 11-Apr-1989 - change name to PGPAGE.
  11255. C 10-Sep-1990 - add identification labelling.
  11256. C 11-Feb-1992 - check if device size has changed.
  11257. C  3-Sep-1992 - allow column ordering of panels.
  11258. C 17-Nov-1994 - move identification to drivers.
  11259. C 23-Nov-1994 - fix bug: character size not getting reset.
  11260. C 23-Jan-1995 - rescale viewport if size of view surface  has changed.
  11261. C-----------------------------------------------------------------------
  11262.       INCLUDE      'f77.PGPLOT/IN'
  11263.       CHARACTER*16 STR
  11264.       LOGICAL      INTER, PGNOTO
  11265.       REAL DUM1, DUM2, XS, YS, XVP1, XVP2, YVP1, YVP2
  11266. C
  11267.       IF (PGNOTO('PGPAGE')) RETURN
  11268. C
  11269.       IF (PGROWS(PGID)) THEN
  11270.         PGNXC(PGID) = PGNXC(PGID) + 1
  11271.         IF (PGNXC(PGID).GT.PGNX(PGID)) THEN
  11272.           PGNXC(PGID) = 1
  11273.           PGNYC(PGID) = PGNYC(PGID) + 1
  11274.           IF (PGNYC(PGID).GT.PGNY(PGID)) PGNYC(PGID) = 1
  11275.         END IF
  11276.       ELSE
  11277.         PGNYC(PGID) = PGNYC(PGID) + 1
  11278.         IF (PGNYC(PGID).GT.PGNY(PGID)) THEN
  11279.           PGNYC(PGID) = 1
  11280.           PGNXC(PGID) = PGNXC(PGID) + 1
  11281.           IF (PGNXC(PGID).GT.PGNX(PGID)) PGNXC(PGID) = 1
  11282.         END IF
  11283.       END IF
  11284.       IF (PGNXC(PGID).EQ.1 .AND. PGNYC(PGID).EQ.1) THEN
  11285.           IF (PGADVS(PGID).EQ.1 .AND. PGPRMP(PGID)) THEN
  11286.               CALL GRTERM
  11287.               CALL GRPROM
  11288.           END IF
  11289.           CALL GRPAGE
  11290.           IF (.NOT.PGPFIX(PGID)) THEN
  11291. C             -- Get current viewport in NDC.
  11292.               CALL PGQVP(0, XVP1, XVP2, YVP1, YVP2)
  11293. C             -- Reset view surface size if it has changed
  11294.               CALL GRSIZE(PGID, XS,YS, DUM1,DUM2,
  11295.      1                    PGXPIN(PGID), PGYPIN(PGID))
  11296.               PGXSZ(PGID) = XS/PGNX(PGID)
  11297.               PGYSZ(PGID) = YS/PGNY(PGID)
  11298. C             -- and character size
  11299.               CALL PGSCH(PGCHSZ)
  11300. C             -- and viewport
  11301.               CALL PGSVP(XVP1, XVP2, YVP1, YVP2)
  11302.           END IF
  11303. C
  11304. C If the device is interactive, call GRBPIC to clear the page.
  11305. C (If the device is not interactive, GRBPIC will be called
  11306. C automatically before the first output; omitting the call here
  11307. C ensures that a blank page is not output.)
  11308. C
  11309.           CALL GRQTYP(STR,INTER)
  11310.           IF (INTER) CALL GRBPIC
  11311.       END IF
  11312.       PGXOFF(PGID) = PGXVP(PGID) + (PGNXC(PGID)-1)*PGXSZ(PGID)
  11313.       PGYOFF(PGID) = PGYVP(PGID) + 
  11314.      1               (PGNY(PGID)-PGNYC(PGID))*PGYSZ(PGID)
  11315. C
  11316. C Window the plot in the new viewport.
  11317. C
  11318.       CALL PGVW
  11319.       PGADVS(PGID) = 1
  11320.       CALL GRTERM
  11321.       END
  11322. C*PGPANL -- switch to a different panel on the view surface
  11323. C%void cpgpanl(int nxc, int nyc);
  11324. C+
  11325.       SUBROUTINE PGPANL(IX, IY)
  11326.       INTEGER IX, IY
  11327. C
  11328. C Start plotting in a different panel. If the view surface has been
  11329. C divided into panels by PGBEG or PGSUBP, this routine can be used to
  11330. C move to a different panel. Note that PGPLOT does not remember what
  11331. C viewport and window were in use in each panel; these should be reset
  11332. C if necessary after calling PGPANL. Nor does PGPLOT clear the panel:
  11333. C call PGERAS after calling PGPANL to do this.
  11334. C
  11335. C Arguments:
  11336. C  IX     (input)  : the horizontal index of the panel (in the range
  11337. C                    1 <= IX <= number of panels in horizontal
  11338. C                    direction).
  11339. C  IY     (input)  : the vertical index of the panel (in the range
  11340. C                    1 <= IY <= number of panels in horizontal
  11341. C                    direction).
  11342. C--
  11343. C  1-Dec-1994 - new routine [TJP].
  11344. C-----------------------------------------------------------------------
  11345.       INCLUDE      'f77.PGPLOT/IN'
  11346.       LOGICAL PGNOTO
  11347. C
  11348. C Check that a device is open.
  11349. C
  11350.       IF (PGNOTO('PGPANL')) RETURN
  11351. C
  11352. C Check arguments.
  11353. C
  11354.       IF (IX.LT.1 .OR. IX.GT.PGNX(PGID) .OR.
  11355.      :    IY.LT.1 .OR. IY.GT.PGNY(PGID)) THEN
  11356.          CALL GRWARN('PGPANL: the requested panel does not exist')
  11357. C
  11358. C Adjust the viewport to the new panel and window the plot
  11359. C in the new viewport.
  11360. C
  11361.       ELSE
  11362.          PGNXC(PGID)  = IX
  11363.          PGNYC(PGID)  = IY
  11364.          PGXOFF(PGID) = PGXVP(PGID) + (IX-1)*PGXSZ(PGID)
  11365.          PGYOFF(PGID) = PGYVP(PGID) + (PGNY(PGID)-IY)*PGYSZ(PGID)
  11366.          CALL PGVW
  11367.       END IF
  11368. C
  11369.       END
  11370. C*PGPAP -- change the size of the view surface 
  11371. C%void cpgpap(float width, float aspect);
  11372. C+
  11373.       SUBROUTINE PGPAP (WIDTH, ASPECT)
  11374.       REAL WIDTH, ASPECT
  11375. C
  11376. C This routine changes the size of the view surface ("paper size") to a
  11377. C specified width and aspect ratio (height/width), in so far as this is
  11378. C possible on the specific device. It is always possible to obtain a
  11379. C view surface smaller than the default size; on some devices (e.g.,
  11380. C printers that print on roll or fan-feed paper) it is possible to 
  11381. C obtain a view surface larger than the default.
  11382. C 
  11383. C This routine should be called either immediately after PGBEG or
  11384. C immediately before PGPAGE. The new size applies to all subsequent
  11385. C images until the next call to PGPAP.
  11386. C
  11387. C Arguments:
  11388. C  WIDTH  (input)  : the requested width of the view surface in inches;
  11389. C                    if WIDTH=0.0, PGPAP will obtain the largest view
  11390. C                    surface available consistent with argument ASPECT.
  11391. C                    (1 inch = 25.4 mm.)
  11392. C  ASPECT (input)  : the aspect ratio (height/width) of the view
  11393. C                    surface; e.g., ASPECT=1.0 gives a square view
  11394. C                    surface, ASPECT=0.618 gives a horizontal
  11395. C                    rectangle, ASPECT=1.618 gives a vertical rectangle.
  11396. C--
  11397. C (22-Apr-1983; bug fixed 7-Jun-1988)
  11398. C  6-Oct-1990 Modified to work correctly on interactive devices.
  11399. C 13-Dec-1990 Make errors non-fatal [TJP].
  11400. C 14-Sep-1994 Fix bug to do with drivers changing view surface size.
  11401. C-----------------------------------------------------------------------
  11402.       INCLUDE  'f77.PGPLOT/IN'
  11403.       LOGICAL  PGNOTO
  11404.       REAL     HDEF, HMAX, HREQ, WDEF, WMAX, WREQ
  11405.       REAL     XSMAX, YSMAX, XSZ, YSZ
  11406. C
  11407.       IF (PGNOTO('PGPAP'))  RETURN
  11408.       IF (WIDTH.LT.0.0 .OR. ASPECT.LE.0.0) THEN
  11409.           CALL GRWARN('PGPAP ignored: invalid arguments')
  11410.           RETURN
  11411.       END IF
  11412. C
  11413.       PGPFIX(PGID) = .TRUE.
  11414. C     -- Find default size WDEF, HDEF and maximum size WMAX, HMAX
  11415. C        of view surface (inches)
  11416.       CALL GRSIZE(PGID,XSZ,YSZ,XSMAX,YSMAX,
  11417.      1            PGXPIN(PGID),PGYPIN(PGID))
  11418.       WDEF = XSZ/PGXPIN(PGID)
  11419.       HDEF = YSZ/PGYPIN(PGID)
  11420.       WMAX = XSMAX/PGXPIN(PGID)
  11421.       HMAX = YSMAX/PGYPIN(PGID)
  11422. C     -- Find desired size WREQ, HREQ of view surface (inches)
  11423.       IF (WIDTH.NE.0.0) THEN
  11424.           WREQ = WIDTH
  11425.           HREQ = WIDTH*ASPECT
  11426.       ELSE
  11427.           WREQ = WDEF
  11428.           HREQ = WDEF*ASPECT
  11429.           IF (HREQ.GT.HDEF) THEN
  11430.               WREQ = HDEF/ASPECT
  11431.               HREQ = HDEF
  11432.           END IF
  11433.       END IF
  11434. C     -- Scale the requested view surface to fit the maximum
  11435. C        dimensions
  11436.       IF (WMAX.GT.0.0 .AND. WREQ.GT.WMAX) THEN
  11437.           WREQ = WMAX
  11438.           HREQ = WMAX*ASPECT
  11439.       END IF
  11440.       IF (HMAX.GT.0.0 .AND. HREQ.GT.HMAX) THEN
  11441.           WREQ = HMAX/ASPECT
  11442.           HREQ = HMAX
  11443.       END IF
  11444. C     -- Establish the new view surface dimensions
  11445.       XSZ = WREQ*PGXPIN(PGID)
  11446.       YSZ = HREQ*PGYPIN(PGID)
  11447.       CALL GRSETS(PGID,XSZ,YSZ)
  11448.       PGXSZ(PGID) = XSZ/PGNX(PGID)
  11449.       PGYSZ(PGID) = YSZ/PGNY(PGID)
  11450.       PGNXC(PGID) = PGNX(PGID)
  11451.       PGNYC(PGID) = PGNY(PGID)
  11452.       CALL PGSCH(1.0)
  11453.       CALL PGVSTD
  11454.       END
  11455. C*PGPAPER -- non-standard alias for PGPAP
  11456. C+
  11457.       SUBROUTINE PGPAPER (WIDTH, ASPECT)
  11458.       REAL WIDTH, ASPECT
  11459. C
  11460. C See description of PGPAP.
  11461. C--
  11462.       CALL PGPAP (WIDTH, ASPECT)
  11463.       END
  11464. C*PGPIXL -- draw pixels
  11465. C%void cpgpixl(const int *ia, int idim, int jdim, int i1, int i2, \
  11466. C% int j1, int j2, float x1, float x2, float y1, float y2);
  11467. C+
  11468.       SUBROUTINE PGPIXL (IA, IDIM, JDIM, I1, I2, J1, J2, 
  11469.      1                   X1, X2, Y1, Y2)
  11470.       INTEGER IDIM, JDIM, I1, I2, J1, J2
  11471.       INTEGER IA(IDIM,JDIM)
  11472.       REAL    X1, X2, Y1, Y2
  11473. C
  11474. C Draw lots of solid-filled (tiny) rectangles aligned with the
  11475. C coordinate axes. Best performance is achieved when output is
  11476. C directed to a pixel-oriented device and the rectangles coincide
  11477. C with the pixels on the device. In other cases, pixel output is
  11478. C emulated.
  11479. C
  11480. C The subsection of the array IA defined by indices (I1:I2, J1:J2)
  11481. C is mapped onto world-coordinate rectangle defined by X1, X2, Y1
  11482. C and Y2. This rectangle is divided into (I2 - I1 + 1) * (J2 - J1 + 1)
  11483. C small rectangles. Each of these small rectangles is solid-filled
  11484. C with the color index specified by the corresponding element of 
  11485. C IA.
  11486. C
  11487. C On most devices, the output region is "opaque", i.e., it obscures
  11488. C all graphical elements previously drawn in the region. But on
  11489. C devices that do not have erase capability, the background shade
  11490. C is "transparent" and allows previously-drawn graphics to show
  11491. C through.
  11492. C
  11493. C Arguments:
  11494. C  IA     (input)  : the array to be plotted.
  11495. C  IDIM   (input)  : the first dimension of array A.
  11496. C  JDIM   (input)  : the second dimension of array A.
  11497. C  I1, I2 (input)  : the inclusive range of the first index
  11498. C                    (I) to be plotted.
  11499. C  J1, J2 (input)  : the inclusive range of the second
  11500. C                    index (J) to be plotted.
  11501. C  X1, Y1 (input)  : world coordinates of one corner of the output
  11502. C                    region
  11503. C  X2, Y2 (input)  : world coordinates of the opposite corner of the
  11504. C                    output region
  11505. C--
  11506. C 16-Jan-1991 - [GvG]
  11507. C-----------------------------------------------------------------------
  11508.       LOGICAL PGNOTO
  11509. C
  11510. C Check inputs.
  11511. C
  11512.       IF (PGNOTO('PGPIXL')) RETURN
  11513.       IF (I1.LT.1 .OR. I2.GT.IDIM .OR. I1.GT.I2 .OR.
  11514.      1    J1.LT.1 .OR. J2.GT.JDIM .OR. J1.GT.J2) THEN
  11515.          CALL GRWARN('PGPIXL: invalid range I1:I2, J1:J2')
  11516.       ELSE
  11517. C
  11518. C Call lower-level routine to do the work.
  11519. C
  11520.          CALL PGBBUF
  11521.          CALL GRPIXL(IA, IDIM, JDIM, I1, I2, J1, J2, X1, X2, Y1, Y2)
  11522.          CALL PGEBUF
  11523.       END IF
  11524. C-----------------------------------------------------------------------
  11525.       END
  11526. C*PGPNTS -- draw one or more graph markers, not all the same
  11527. C%void cpgpnts(int n, const float *x, const float *y, \
  11528. C% const int *symbol, int ns);
  11529. C+
  11530.       SUBROUTINE PGPNTS (N, X, Y, SYMBOL, NS)
  11531.       INTEGER N, NS
  11532.       REAL X(*), Y(*)
  11533.       INTEGER SYMBOL(*)
  11534. C
  11535. C Draw Graph Markers. Unlike PGPT, this routine can draw a different
  11536. C symbol at each point. The markers
  11537. C are drawn using the current values of attributes color-index,
  11538. C line-width, and character-height (character-font applies if the symbol
  11539. C number is >31).  If the point to be marked lies outside the window,
  11540. C no marker is drawn.  The "pen position" is changed to
  11541. C (XPTS(N),YPTS(N)) in world coordinates (if N > 0).
  11542. C
  11543. C Arguments:
  11544. C  N      (input)  : number of points to mark.
  11545. C  X      (input)  : world x-coordinate of the points.
  11546. C  Y      (input)  : world y-coordinate of the points.
  11547. C  SYMBOL (input)  : code number of the symbol to be plotted at each
  11548. C                    point (see PGPT).
  11549. C  NS     (input)  : number of values in the SYMBOL array.  If NS <= N,
  11550. C                    then the first NS points are drawn using the value
  11551. C                    of SYMBOL(I) at (X(I), Y(I)) and SYMBOL(1) for all
  11552. C                    the values of (X(I), Y(I)) where I > NS.
  11553. C
  11554. C Note: the dimension of arrays X and Y must be greater than or equal
  11555. C to N and the dimension of the array SYMBOL must be greater than or
  11556. C equal to NS.  If N is 1, X and Y may be scalars (constants or
  11557. C variables).  If NS is 1, then SYMBOL may be a scalar.  If N is
  11558. C less than 1, nothing is drawn.
  11559. C--
  11560. C 11-Mar-1991 - new routine [JM].
  11561. C-----------------------------------------------------------------------
  11562.       INTEGER I, SYMB
  11563. C
  11564.       IF (N.LT.1) RETURN
  11565.       CALL PGBBUF
  11566.       DO 10 I=1,N
  11567.           IF (I .LE. NS) THEN
  11568.               SYMB = SYMBOL(I)
  11569.           ELSE
  11570.               SYMB = SYMBOL(1)
  11571.           END IF
  11572.           CALL PGPT(1, X(I), Y(I), SYMB)
  11573.    10 CONTINUE
  11574.       CALL PGEBUF
  11575.       END
  11576. C*PGPOINT -- non-standard alias for PGPT
  11577. C+
  11578.       SUBROUTINE PGPOINT (N, XPTS, YPTS, SYMBOL)
  11579.       INTEGER N
  11580.       REAL XPTS(*), YPTS(*)
  11581.       INTEGER SYMBOL
  11582. C
  11583. C See description of PGPT.
  11584. C--
  11585.       CALL PGPT (N, XPTS, YPTS, SYMBOL)
  11586.       END
  11587. C*PGPOLY -- fill a polygonal area with shading
  11588. C%void cpgpoly(int n, const float *xpts, const float *ypts);
  11589. C+
  11590.       SUBROUTINE PGPOLY (N, XPTS, YPTS)
  11591.       INTEGER N
  11592.       REAL XPTS(*), YPTS(*)
  11593. C
  11594. C Fill-area primitive routine: shade the interior of a closed
  11595. C polygon in the current window.  The action of this routine depends
  11596. C on the setting of the Fill-Area Style attribute (see PGSFS).
  11597. C The polygon is clipped at the edge of the
  11598. C window. The pen position is changed to (XPTS(1),YPTS(1)) in world
  11599. C coordinates (if N > 1).  If the polygon is not convex, a point is
  11600. C assumed to lie inside the polygon if a straight line drawn to
  11601. C infinity intersects and odd number of the polygon's edges.
  11602. C
  11603. C Arguments:
  11604. C  N      (input)  : number of points defining the polygon; the
  11605. C                    line consists of N straight-line segments,
  11606. C                    joining points 1 to 2, 2 to 3,... N-1 to N, N to 1.
  11607. C                    N should be greater than 2 (if it is 2 or less,
  11608. C                    nothing will be drawn).
  11609. C  XPTS   (input)  : world x-coordinates of the vertices.
  11610. C  YPTS   (input)  : world y-coordinates of the vertices.
  11611. C                    Note: the dimension of arrays XPTS and YPTS must be
  11612. C                    greater than or equal to N.
  11613. C--
  11614. C 21-Nov-1983 - [TJP].
  11615. C 16-Jul-1984 - revised to shade polygon with GRFA [TJP].
  11616. C 21-Oct-1985 - test PGFAS [TJP].
  11617. C 25-Nov-1994 - implement clipping [TJP].
  11618. C 13-Jan-1994 - fix bug in clipping [TJP].
  11619. C  6-Mar-1995 - add support for fill styles 3 and 4 [TJP].
  11620. C 12-Sep-1995 - fix another bug in clipping [TJP].
  11621. C-----------------------------------------------------------------------
  11622.       INTEGER MAXOUT
  11623.       PARAMETER (MAXOUT=1000)
  11624.       LOGICAL CLIP
  11625.       INTEGER I, N1, N2, N3, N4
  11626.       REAL    QX(MAXOUT), QY(MAXOUT), RX(MAXOUT), RY(MAXOUT)
  11627.       REAL    XL, XH, YL, YH
  11628.       LOGICAL PGNOTO
  11629.       INCLUDE 'f77.PGPLOT/IN'
  11630. C
  11631.       IF (PGNOTO('PGPOLY')) RETURN
  11632.       IF (N.LT.1) RETURN
  11633. C
  11634. C Outline style, or polygon of less than 3 vertices.
  11635. C
  11636.       IF (PGFAS(PGID).EQ.2 .OR. N.LT.3) THEN
  11637.          CALL PGBBUF
  11638.          CALL GRMOVA(XPTS(N),YPTS(N))
  11639.          DO 10 I=1,N
  11640.             CALL GRLINA(XPTS(I),YPTS(I))
  11641.  10      CONTINUE
  11642. C
  11643. C Hatched style.
  11644. C
  11645.       ELSE IF (PGFAS(PGID).EQ.3) THEN
  11646.          CALL PGBBUF
  11647.          CALL PGHTCH(N, XPTS, YPTS, 0.0)
  11648.       ELSE IF (PGFAS(PGID).EQ.4) THEN
  11649.          CALL PGBBUF
  11650.          CALL PGHTCH(N, XPTS, YPTS, 0.0)
  11651.          CALL PGHTCH(N, XPTS, YPTS, 90.0)
  11652.       ELSE
  11653. C     
  11654. C Test whether polygon lies completely in the window.
  11655. C     
  11656.          CLIP = .FALSE.
  11657.          XL = MIN(PGXBLC(PGID),PGXTRC(PGID))
  11658.          XH = MAX(PGXBLC(PGID),PGXTRC(PGID))
  11659.          YL = MIN(PGYBLC(PGID),PGYTRC(PGID))
  11660.          YH = MAX(PGYBLC(PGID),PGYTRC(PGID))
  11661.          DO 20 I=1,N
  11662.             IF (XPTS(I).LT.XL .OR. XPTS(I).GT.XH .OR.
  11663.      :           YPTS(I).LT.YL .OR. YPTS(I).GT.YH) THEN
  11664.                CLIP = .TRUE.
  11665.                GOTO 30
  11666.             END IF
  11667.  20      CONTINUE
  11668.  30      CONTINUE
  11669. C     
  11670. C Filled style, no clipping required.
  11671. C     
  11672.          CALL PGBBUF
  11673.          IF (.NOT.CLIP) THEN
  11674.             CALL GRFA(N,XPTS,YPTS)
  11675. C     
  11676. C Filled style, clipping required: the vertices of the clipped
  11677. C polygon are put in temporary arrays QX,QY, RX, RY.
  11678. C     
  11679.          ELSE
  11680.             CALL GRPOCL(N,  XPTS, YPTS, 1, XL, MAXOUT, N1, QX, QY)
  11681.             IF (N1.GT.MAXOUT) GOTO 40
  11682.             IF (N1.LT.3) GOTO 50
  11683.             CALL GRPOCL(N1, QX,   QY,   2, XH, MAXOUT, N2, RX, RY)
  11684.             IF (N2.GT.MAXOUT) GOTO 40
  11685.             IF (N2.LT.3) GOTO 50
  11686.             CALL GRPOCL(N2, RX,   RY,   3, YL, MAXOUT, N3, QX, QY)
  11687.             IF (N3.GT.MAXOUT) GOTO 40
  11688.             IF (N3.LT.3) GOTO 50
  11689.             CALL GRPOCL(N3, QX,   QY,   4, YH, MAXOUT, N4, RX, RY)
  11690.             IF (N4.GT.MAXOUT) GOTO 40
  11691.             IF (N4.GT.0) CALL GRFA(N4,RX,RY)
  11692.             GOTO 50
  11693.  40         CALL GRWARN('PGPOLY: polygon is too complex')
  11694.  50         CONTINUE
  11695.          END IF
  11696.       END IF
  11697. C
  11698. C Set the current pen position.
  11699. C
  11700.       CALL GRMOVA(XPTS(1),YPTS(1))
  11701.       CALL PGEBUF
  11702. C
  11703.       END
  11704. C*PGPT -- draw one or more graph markers
  11705. C%void cpgpt(int n, const float *xpts, const float *ypts, int symbol);
  11706. C+
  11707.       SUBROUTINE PGPT (N, XPTS, YPTS, SYMBOL)
  11708.       INTEGER N
  11709.       REAL XPTS(*), YPTS(*)
  11710.       INTEGER SYMBOL
  11711. C
  11712. C Primitive routine to draw Graph Markers (polymarker). The markers
  11713. C are drawn using the current values of attributes color-index,
  11714. C line-width, and character-height (character-font applies if the symbol
  11715. C number is >31).  If the point to be marked lies outside the window,
  11716. C no marker is drawn.  The "pen position" is changed to
  11717. C (XPTS(N),YPTS(N)) in world coordinates (if N > 0).
  11718. C
  11719. C Arguments:
  11720. C  N      (input)  : number of points to mark.
  11721. C  XPTS   (input)  : world x-coordinates of the points.
  11722. C  YPTS   (input)  : world y-coordinates of the points.
  11723. C  SYMBOL (input)  : code number of the symbol to be drawn at each 
  11724. C                    point:
  11725. C                    -1, -2  : a single dot (diameter = current
  11726. C                              line width).
  11727. C                    -3..-31 : a regular polygon with ABS(SYMBOL)
  11728. C                              edges (style set by current fill style).
  11729. C                    0..31   : standard marker symbols.
  11730. C                    32..127 : ASCII characters (in current font).
  11731. C                              e.g. to use letter F as a marker, let
  11732. C                              SYMBOL = ICHAR('F'). 
  11733. C                    > 127  :  a Hershey symbol number.
  11734. C
  11735. C Note: the dimension of arrays X and Y must be greater than or equal
  11736. C to N. If N is 1, X and Y may be scalars (constants or variables). If
  11737. C N is less than 1, nothing is drawn.
  11738. C--
  11739. C 27-Nov-1986
  11740. C 17-Dec-1990 - add polygons [PAH].
  11741. C-----------------------------------------------------------------------
  11742.       LOGICAL PGNOTO
  11743. C
  11744.       IF (N.LT.1) RETURN
  11745.       IF (PGNOTO('PGPT')) RETURN
  11746.       CALL PGBBUF
  11747. C
  11748.       IF (SYMBOL.GE.0 .OR. SYMBOL.LE.-3) THEN
  11749.           CALL GRMKER(SYMBOL,.FALSE.,N,XPTS,YPTS)
  11750.       ELSE
  11751.           CALL GRVCT0(3,.FALSE.,N,XPTS,YPTS)
  11752.       END IF
  11753.       CALL GRMOVA(XPTS(N),YPTS(N))
  11754.       CALL PGEBUF
  11755.       END
  11756. C*PGPTEXT -- non-standard alias for PGPTXT
  11757. C+
  11758.       SUBROUTINE PGPTEXT (X, Y, ANGLE, FJUST, TEXT)
  11759.       REAL X, Y, ANGLE, FJUST
  11760.       CHARACTER*(*) TEXT
  11761. C
  11762. C See description of PGPTXT.
  11763. C--
  11764.       CALL PGPTXT (X, Y, ANGLE, FJUST, TEXT)
  11765.       END
  11766. C*PGPTXT -- write text at arbitrary position and angle
  11767. C%void cpgptxt(float x, float y, float angle, float fjust, \
  11768. C% const char *text);
  11769. C+
  11770.       SUBROUTINE PGPTXT (X, Y, ANGLE, FJUST, TEXT)
  11771.       REAL X, Y, ANGLE, FJUST
  11772.       CHARACTER*(*) TEXT
  11773. C
  11774. C Primitive routine for drawing text. The text may be drawn at any
  11775. C angle with the horizontal, and may be centered or left- or right-
  11776. C justified at a specified position.  Routine PGTEXT provides a
  11777. C simple interface to PGPTXT for horizontal strings. Text is drawn
  11778. C using the current values of attributes color-index, line-width,
  11779. C character-height, and character-font.  Text is NOT subject to
  11780. C clipping at the edge of the window.
  11781. C
  11782. C Arguments:
  11783. C  X      (input)  : world x-coordinate.
  11784. C  Y      (input)  : world y-coordinate. The string is drawn with the
  11785. C                    baseline of all the characters passing through
  11786. C                    point (X,Y); the positioning of the string along
  11787. C                    this line is controlled by argument FJUST.
  11788. C  ANGLE  (input)  : angle, in degrees, that the baseline is to make
  11789. C                    with the horizontal, increasing counter-clockwise
  11790. C                    (0.0 is horizontal).
  11791. C  FJUST  (input)  : controls horizontal justification of the string.
  11792. C                    If FJUST = 0.0, the string will be left-justified
  11793. C                    at the point (X,Y); if FJUST = 0.5, it will be
  11794. C                    centered, and if FJUST = 1.0, it will be right
  11795. C                    justified. [Other values of FJUST give other
  11796. C                    justifications.]
  11797. C  TEXT   (input)  : the character string to be plotted.
  11798. C--
  11799. C (2-May-1983)
  11800. C 31-Jan-1985 - convert to Fortran-77 standard...
  11801. C 13-Feb-1988 - correct a PGBBUF/PGEBUF mismatch if string is blank.
  11802. C 16-Oct-1993 - erase background of opaque text.
  11803. C-----------------------------------------------------------------------
  11804.       INCLUDE 'f77.PGPLOT/IN'
  11805.       INTEGER CI, I, L, GRTRIM
  11806.       REAL D, XP, YP
  11807.       REAL XBOX(4), YBOX(4)
  11808.       LOGICAL PGNOTO
  11809. C
  11810.       IF (PGNOTO('PGPTXT')) RETURN
  11811.       CALL PGBBUF
  11812. C
  11813.       L = GRTRIM(TEXT)
  11814.       D = 0.0
  11815.       IF (FJUST.NE.0.0) CALL GRLEN(TEXT(1:L),D)
  11816.       XP = PGXORG(PGID)+X*PGXSCL(PGID) - D*FJUST*COS(ANGLE/57.29578)
  11817.       YP = PGYORG(PGID)+Y*PGYSCL(PGID) - D*FJUST*SIN(ANGLE/57.29578)
  11818.       IF (PGTBCI(PGID).GE.0) THEN
  11819.           CALL GRQTXT (ANGLE, XP, YP, TEXT(1:L), XBOX, YBOX)
  11820.           DO 25 I=1,4
  11821.               XBOX(I) = (XBOX(I)-PGXORG(PGID))/PGXSCL(PGID)
  11822.               YBOX(I) = (YBOX(I)-PGYORG(PGID))/PGYSCL(PGID)
  11823.    25     CONTINUE
  11824.           CALL PGQCI(CI)
  11825.           CALL PGSCI(PGTBCI(PGID))
  11826.           CALL GRFA(4, XBOX, YBOX)
  11827.           CALL PGSCI(CI)
  11828.       END IF
  11829.       CALL GRTEXT(.TRUE. ,ANGLE, .TRUE., XP, YP, TEXT(1:L))
  11830.    30 CALL PGEBUF
  11831.       END
  11832. C*PGQAH -- inquire arrow-head style
  11833. C%void cpgqah(int *fs, float *angle, float *vent);
  11834. C+
  11835.       SUBROUTINE PGQAH (FS, ANGLE, VENT)
  11836.       INTEGER  FS
  11837.       REAL ANGLE, VENT
  11838. C
  11839. C Query the style to be used for arrowheads drawn with routine PGARRO.
  11840. C
  11841. C Argument:
  11842. C  FS     (output) : FS = 1 => filled; FS = 2 => outline.
  11843. C  ANGLE  (output) : the acute angle of the arrow point, in degrees.
  11844. C  VENT   (output) : the fraction of the triangular arrow-head that
  11845. C                    is cut away from the back. 
  11846. C--
  11847. C 13-Oct-1992 - new routine [TJP].
  11848. C-----------------------------------------------------------------------
  11849.       INCLUDE 'f77.PGPLOT/IN'
  11850. C
  11851.       FS = PGAHS(PGID)
  11852.       ANGLE = PGAHA(PGID)
  11853.       VENT = PGAHV(PGID)
  11854. C
  11855.       END
  11856. C*PGQCF -- inquire character font
  11857. C%void cpgqcf(int *font);
  11858. C+
  11859.       SUBROUTINE PGQCF (FONT)
  11860.       INTEGER  FONT
  11861. C
  11862. C Query the current Character Font (set by routine PGSCF).
  11863. C
  11864. C Argument:
  11865. C  FONT   (output)   : the current font number (in range 1-4).
  11866. C--
  11867. C  5-Nov-1985 - new routine [TJP].
  11868. C 25-OCT-1993 - changed name of argument [TJP].
  11869. C-----------------------------------------------------------------------
  11870.       LOGICAL PGNOTO
  11871. C
  11872.       IF (PGNOTO('PGQCF')) THEN
  11873.          FONT = 1
  11874.       ELSE
  11875.          CALL GRQFNT(FONT)
  11876.       END IF
  11877.       END
  11878. C*PGQCH -- inquire character height
  11879. C%void cpgqch(float *size);
  11880. C+
  11881.       SUBROUTINE PGQCH (SIZE)
  11882.       REAL SIZE
  11883. C
  11884. C Query the Character Size attribute (set by routine PGSCH).
  11885. C
  11886. C Argument:
  11887. C  SIZE   (output) : current character size (dimensionless multiple of
  11888. C                    the default size).
  11889. C--
  11890. C  5-Nov-1985 - new routine [TJP].
  11891. C-----------------------------------------------------------------------
  11892.       INCLUDE  'f77.PGPLOT/IN'
  11893.       LOGICAL  PGNOTO
  11894. C
  11895.       IF (PGNOTO('PGQCH')) THEN
  11896.           SIZE = 1.0
  11897.       ELSE
  11898.           SIZE = PGCHSZ(PGID)
  11899.       END IF
  11900.       END
  11901. C*PGQCI -- inquire color index
  11902. C%void cpgqci(int *ci);
  11903. C+
  11904.       SUBROUTINE PGQCI (CI)
  11905.       INTEGER  CI
  11906. C
  11907. C Query the Color Index attribute (set by routine PGSCI).
  11908. C
  11909. C Argument:
  11910. C  CI     (output) : the current color index (in range 0-max). This is
  11911. C                    the color index actually in use, and may differ
  11912. C                    from the color index last requested by PGSCI if
  11913. C                    that index is not available on the output device.
  11914. C--
  11915. C  5-Nov-1985 - new routine [TJP].
  11916. C-----------------------------------------------------------------------
  11917.       LOGICAL PGNOTO
  11918. C
  11919.       IF (PGNOTO('PGQCI')) THEN
  11920.          CI = 1
  11921.       ELSE
  11922.          CALL GRQCI(CI)
  11923.       END IF
  11924.       END
  11925. C*PGQCIR -- inquire color index range
  11926. C%void cpgqcir(int *icilo, int *icihi);
  11927. C+
  11928.       SUBROUTINE PGQCIR(ICILO, ICIHI)
  11929.       INTEGER   ICILO, ICIHI
  11930. C
  11931. C Query the color index range to be used for producing images with
  11932. C PGGRAY or PGIMAG, as set by routine PGSCIR or by device default.
  11933. C
  11934. C Arguments:
  11935. C  ICILO  (output) : the lowest color index to use for images
  11936. C  ICIHI  (output) : the highest color index to use for images
  11937. C--
  11938. C 1994-Mar-17 : new routine [AFT/TJP].
  11939. C-----------------------------------------------------------------------
  11940.       INCLUDE 'f77.PGPLOT/IN'
  11941. C---
  11942.       ICILO = PGMNCI(PGID)
  11943.       ICIHI = PGMXCI(PGID)
  11944. C
  11945.       END
  11946. C*PGQCOL -- inquire color capability
  11947. C%void cpgqcol(int *ci1, int *ci2);
  11948. C+
  11949.       SUBROUTINE PGQCOL (CI1, CI2)
  11950.       INTEGER  CI1, CI2
  11951. C
  11952. C Query the range of color indices available on the current device.
  11953. C
  11954. C Argument:
  11955. C  CI1    (output) : the minimum available color index. This will be
  11956. C                    either 0 if the device can write in the
  11957. C                    background color, or 1 if not.
  11958. C  CI2    (output) : the maximum available color index. This will be
  11959. C                    1 if the device has no color capability, or a
  11960. C                    larger number (e.g., 3, 7, 15, 255).
  11961. C--
  11962. C 31-May-1989 - new routine [TJP].
  11963. C-----------------------------------------------------------------------
  11964.       CALL GRQCOL(CI1, CI2)
  11965.       END
  11966. C*PGQCR  -- inquire color representation
  11967. C%void cpgqcr(int ci, float *cr, float *cg, float *cb);
  11968. C+
  11969.       SUBROUTINE PGQCR (CI, CR, CG, CB)
  11970.       INTEGER CI
  11971.       REAL    CR, CG, CB
  11972. C
  11973. C Query the RGB colors associated with a color index.
  11974. C
  11975. C Arguments:
  11976. C  CI  (input)  : color index
  11977. C  CR  (output) : red, green and blue intensities
  11978. C  CG  (output)   in the range 0.0 to 1.0
  11979. C  CB  (output)
  11980. C--
  11981. C 7-Apr-1992 - new routine [DLT]
  11982. C-----------------------------------------------------------------------
  11983.       CALL GRQCR(CI, CR, CG, CB)
  11984.       END
  11985. C*PGQCS  -- inquire character height in a variety of units
  11986. C%void cpgqcs(int units, float *xch, float *ych);
  11987. C+
  11988.       SUBROUTINE PGQCS(UNITS, XCH, YCH)
  11989.       INTEGER UNITS
  11990.       REAL XCH, YCH
  11991. C
  11992. C Return the current PGPLOT character height in a variety of units.
  11993. C This routine provides facilities that are not available via PGQCH.
  11994. C Use PGQCS if the character height is required in units other than
  11995. C those used in PGSCH.
  11996. C
  11997. C The PGPLOT "character height" is a dimension that scales with the
  11998. C size of the view surface and with the scale-factor specified with
  11999. C routine PGSCH. The default value is 1/40th of the height or width
  12000. C of the view surface (whichever is less); this value is then
  12001. C multiplied by the scale-factor supplied with PGSCH. Note that it
  12002. C is a nominal height only; the actual character size depends on the
  12003. C font and is usually somewhat smaller.
  12004. C
  12005. C Arguments:
  12006. C  UNITS  (input)  : Used to specify the units of the output value:
  12007. C                    UNITS = 0 : normalized device coordinates
  12008. C                    UNITS = 1 : inches
  12009. C                    UNITS = 2 : millimeters
  12010. C                    UNITS = 3 : pixels
  12011. C                    UNITS = 4 : world coordinates
  12012. C                    Other values give an error message, and are
  12013. C                    treated as 0.
  12014. C  XCH    (output) : The character height for text written with a
  12015. C                    vertical baseline.
  12016. C  YCH    (output) : The character height for text written with
  12017. C                    a horizontal baseline (the usual case).
  12018. C
  12019. C The character height is returned in both XCH and YCH.
  12020. C
  12021. C If UNITS=1 or UNITS=2, XCH and YCH both receive the same value.
  12022. C
  12023. C If UNITS=3, XCH receives the height in horizontal pixel units, and YCH
  12024. C receives the height in vertical pixel units; on devices for which the
  12025. C pixels are not square, XCH and YCH will be different.
  12026. C
  12027. C If UNITS=4, XCH receives the height in horizontal world coordinates
  12028. C (as used for the x-axis), and YCH receives the height in vertical
  12029. C world coordinates (as used for the y-axis). Unless special care has
  12030. C been taken to achive equal world-coordinate scales on both axes, the
  12031. C values of XCH and YCH will be different.
  12032. C
  12033. C If UNITS=0, XCH receives the character height as a fraction of the
  12034. C horizontal dimension of the view surface, and YCH receives the
  12035. C character height as a fraction of the vertical dimension of the view
  12036. C surface.
  12037. C--
  12038. C 15-Oct-1992 - new routine [MCS].
  12039. C  4-Dec-1992 - added more explanation [TJP].
  12040. C  5-Sep-1995 - add UNITS=4; correct error for non-square pixels [TJP].
  12041. C-----------------------------------------------------------------------
  12042.       INCLUDE 'f77.PGPLOT/IN'
  12043.       LOGICAL PGNOTO
  12044.       REAL RATIO
  12045. C                                        Conversion factor inches -> mm
  12046.       REAL INTOMM
  12047.       PARAMETER (INTOMM=25.4)
  12048. C-----------------------------------------------------------------------
  12049.       IF (PGNOTO('PGQCS')) RETURN
  12050.       RATIO = PGYPIN(PGID)/PGXPIN(PGID)
  12051. C
  12052. C Return the character height in the required units.
  12053. C
  12054. C                                        Inches.
  12055.       IF (UNITS.EQ.1) THEN
  12056.         XCH = PGYSP(PGID)/PGXPIN(PGID)
  12057.         YCH = XCH
  12058. C                                        Millimeters.
  12059.       ELSE IF (UNITS.EQ.2) THEN
  12060.         XCH = PGYSP(PGID)/PGXPIN(PGID) * INTOMM
  12061.         YCH = XCH
  12062. C                                        Pixels.
  12063.       ELSE IF (UNITS.EQ.3) THEN
  12064.         XCH = PGYSP(PGID)
  12065.         YCH = PGYSP(PGID)*RATIO
  12066. C                                        World coordinates.
  12067.       ELSE IF (UNITS.EQ.4) THEN
  12068.          XCH = PGYSP(PGID)/PGXSCL(PGID)
  12069.          YCH = PGYSP(PGID)*RATIO/PGYSCL(PGID)
  12070. C                                        Normalized device coords, or
  12071. C                                        unknown.
  12072.       ELSE
  12073.         XCH = PGYSP(PGID)/PGXSZ(PGID)
  12074.         YCH = PGYSP(PGID)*RATIO/PGYSZ(PGID)
  12075.         IF (UNITS.NE.0)
  12076.      :       CALL GRWARN('Invalid "UNITS" argument in PGQCS.')
  12077.       END IF
  12078.       END
  12079. C*PGQFS -- inquire fill-area style
  12080. C%void cpgqfs(int *fs);
  12081. C+
  12082.       SUBROUTINE PGQFS (FS)
  12083.       INTEGER  FS
  12084. C
  12085. C Query the current Fill-Area Style attribute (set by routine
  12086. C PGSFS).
  12087. C
  12088. C Argument:
  12089. C  FS     (output) : the current fill-area style:
  12090. C                      FS = 1 => solid (default)
  12091. C                      FS = 2 => outline
  12092. C                      FS = 3 => hatched
  12093. C                      FS = 4 => cross-hatched
  12094. C--
  12095. C  5-Nov-1985 - new routine [TJP].
  12096. C  6-Mar-1995 - add styles 3 and 4 [TJP].
  12097. C-----------------------------------------------------------------------
  12098.       INCLUDE 'f77.PGPLOT/IN'
  12099.       LOGICAL PGNOTO
  12100. C
  12101.       IF (PGNOTO('PGQFS')) THEN
  12102.           FS = 1
  12103.       ELSE
  12104.           FS = PGFAS(PGID)
  12105.       END IF
  12106.       END
  12107. C*PGQHS -- inquire hatching style
  12108. C%void cpgqhs(float *angle, float *sepn, float* phase);
  12109. C+
  12110.       SUBROUTINE PGQHS (ANGLE, SEPN, PHASE)
  12111.       REAL ANGLE, SEPN, PHASE
  12112. C
  12113. C Query the style to be used hatching (fill area with fill-style 3).
  12114. C
  12115. C Arguments:
  12116. C  ANGLE  (output) : the angle the hatch lines make with the
  12117. C                    horizontal, in degrees, increasing 
  12118. C                    counterclockwise (this is an angle on the
  12119. C                    view surface, not in world-coordinate space).
  12120. C  SEPN   (output) : the spacing of the hatch lines. The unit spacing
  12121. C                    is 1 percent of the smaller of the height or
  12122. C                    width of the view surface.
  12123. C  PHASE  (output) : a real number between 0 and 1; the hatch lines
  12124. C                    are displaced by this fraction of SEPN from a
  12125. C                    fixed reference.  Adjacent regions hatched with the
  12126. C                    same PHASE have contiguous hatch lines.
  12127. C--
  12128. C 26-Feb-1995 - new routine [TJP].
  12129. C 19-Jun-1995 - correct synopsis [TJP].
  12130. C-----------------------------------------------------------------------
  12131.       INCLUDE 'f77.PGPLOT/IN'
  12132. C
  12133.       ANGLE = PGHSA(PGID)
  12134.       SEPN  = PGHSS(PGID)
  12135.       PHASE = PGHSP(PGID)
  12136. C
  12137.       END
  12138. C*PGQID -- inquire current device identifier
  12139. C%void cpgqid(int *id);
  12140. C+
  12141.       SUBROUTINE PGQID (ID)
  12142.       INTEGER  ID
  12143. C
  12144. C This subroutine returns the identifier of the currently
  12145. C selected device, or 0 if no device is selected.  The identifier is
  12146. C assigned when PGOPEN is called to open the device, and may be used
  12147. C as an argument to PGSLCT.  Each open device has a different
  12148. C identifier.
  12149. C
  12150. C [This routine was added to PGPLOT in Version 5.1.0.]
  12151. C
  12152. C Argument:
  12153. C  ID     (output) : the identifier of the current device, or 0 if
  12154. C                    no device is currently selected.
  12155. C--
  12156. C 22-Dec-1995 - new routine [TJP].
  12157. C-----------------------------------------------------------------------
  12158.       INCLUDE 'f77.PGPLOT/IN'
  12159. C
  12160.       ID = PGID
  12161.       END
  12162. C*PGQINF -- inquire PGPLOT general information
  12163. C%void cpgqinf(const char *item, char *value, int *value_length);
  12164. C+
  12165.       SUBROUTINE PGQINF (ITEM, VALUE, LENGTH)
  12166.       CHARACTER*(*) ITEM, VALUE
  12167.       INTEGER LENGTH
  12168. C
  12169. C This routine can be used to obtain miscellaneous information about
  12170. C the PGPLOT environment. Input is a character string defining the
  12171. C information required, and output is a character string containing the
  12172. C requested information.
  12173. C
  12174. C The following item codes are accepted (note that the strings must
  12175. C match exactly, except for case, but only the first 8 characters are
  12176. C significant). For items marked *, PGPLOT must be in the OPEN state
  12177. C for the inquiry to succeed. If the inquiry is unsuccessful, either
  12178. C because the item code is not recognized or because the information
  12179. C is not available, a question mark ('?') is returned.
  12180. C
  12181. C   'VERSION'     - version of PGPLOT software in use.
  12182. C   'STATE'       - status of PGPLOT ('OPEN' if a graphics device
  12183. C                   is open for output, 'CLOSED' otherwise).
  12184. C   'USER'        - the username associated with the calling program.
  12185. C   'NOW'         - current date and time (e.g., '17-FEB-1986 10:04').
  12186. C   'DEVICE'    * - current PGPLOT device or file.
  12187. C   'FILE'      * - current PGPLOT device or file.
  12188. C   'TYPE'      * - device-type of the current PGPLOT device.
  12189. C   'DEV/TYPE'  * - current PGPLOT device and type, in a form which
  12190. C                   is acceptable as an argument for PGBEG.
  12191. C   'HARDCOPY'  * - is the current device a hardcopy device? ('YES' or
  12192. C                   'NO').
  12193. C   'TERMINAL'  * - is the current device the user's interactive
  12194. C                   terminal? ('YES' or 'NO').
  12195. C   'CURSOR'    * - does the current device have a graphics cursor?
  12196. C                   ('YES' or 'NO').
  12197. C
  12198. C Arguments:
  12199. C  ITEM  (input)  : character string defining the information to
  12200. C                   be returned; see above for a list of possible
  12201. C                   values.
  12202. C  VALUE (output) : returns a character-string containing the
  12203. C                   requested information, truncated to the length 
  12204. C                   of the supplied string or padded on the right with 
  12205. C                   spaces if necessary.
  12206. C  LENGTH (output): the number of characters returned in VALUE
  12207. C                   (excluding trailing blanks).
  12208. C--
  12209. C 18-Feb-1988 - [TJP].
  12210. C 30-Aug-1988 - remove pseudo logical use of IER.
  12211. C 12-Mar-1992 - change comments for clarity.
  12212. C 17-Apr-1995 - clean up some zero-length string problems [TJP].
  12213. C  7-Jul-1995 - get cursor information directly from driver [TJP].
  12214. C-----------------------------------------------------------------------
  12215.       INCLUDE 'f77.PGPLOT/IN'
  12216.       INTEGER IER, L1, GRTRIM
  12217.       LOGICAL INTER, SAME
  12218.       CHARACTER*8 TEST
  12219.       CHARACTER*64 DEV1
  12220. C
  12221. C Initialize PGPLOT if necessary.
  12222. C
  12223.       CALL PGINIT
  12224. C
  12225.       CALL GRTOUP(TEST,ITEM)
  12226.       IF (TEST.EQ.'USER') THEN
  12227.           CALL GRUSER(VALUE, LENGTH)
  12228.           IER = 1
  12229.       ELSE IF (TEST.EQ.'NOW') THEN
  12230.           CALL GRDATE(VALUE, LENGTH)
  12231.           IER = 1
  12232.       ELSE IF (TEST.EQ.'VERSION') THEN
  12233.           VALUE = 'v5.1.1'
  12234.           LENGTH = 6
  12235.           IER = 1
  12236.       ELSE IF (TEST.EQ.'STATE') THEN
  12237.           IF (PGID.LT.1 .OR. PGID.GT.PGMAXD) THEN
  12238.              VALUE = 'CLOSED'
  12239.              LENGTH = 6
  12240.           ELSE IF (PGDEVS(PGID).EQ.0) THEN
  12241.              VALUE = 'CLOSED'
  12242.              LENGTH = 6
  12243.           ELSE
  12244.              VALUE = 'OPEN'
  12245.              LENGTH = 4
  12246.           END IF
  12247.           IER = 1
  12248.       ELSE IF (PGID.LT.1 .OR. PGID.GT.PGMAXD) THEN
  12249.           IER = 0
  12250.       ELSE IF (PGDEVS(PGID).EQ.0) THEN
  12251.           IER = 0
  12252.       ELSE IF (TEST.EQ.'DEV/TYPE') THEN
  12253.           CALL GRQDT(VALUE)
  12254.           LENGTH = GRTRIM(VALUE)
  12255.           IER = 0
  12256.           IF (LENGTH.GT.0) IER = 1
  12257.       ELSE IF (TEST.EQ.'DEVICE' .OR. TEST.EQ.'FILE') THEN
  12258.           CALL GRQDEV(VALUE, LENGTH)
  12259.           IER = 1
  12260.       ELSE IF (TEST.EQ.'TERMINAL') THEN
  12261.           CALL GRQDEV(DEV1, L1)
  12262.           IF (L1.GE.1) THEN
  12263.              CALL GRTTER(DEV1(1:L1), SAME)
  12264.           ELSE
  12265.              SAME = .FALSE.
  12266.           END IF
  12267.           IF (SAME) THEN
  12268.               VALUE = 'YES'
  12269.               LENGTH = 3
  12270.           ELSE
  12271.               VALUE = 'NO'
  12272.               LENGTH = 2
  12273.           END IF
  12274.           IER = 1
  12275.       ELSE IF (TEST.EQ.'TYPE') THEN
  12276.           CALL GRQTYP(VALUE,INTER)
  12277.           LENGTH = GRTRIM(VALUE)
  12278.           IER = 0
  12279.           IF (LENGTH.GT.0) IER = 1
  12280.       ELSE IF (TEST.EQ.'HARDCOPY') THEN
  12281.           CALL GRQTYP(VALUE,INTER)
  12282.           IF (INTER) THEN
  12283.               VALUE = 'NO'
  12284.               LENGTH = 2
  12285.           ELSE
  12286.               VALUE = 'YES'
  12287.               LENGTH = 3
  12288.           END IF
  12289.           IER = 1
  12290.       ELSE IF (TEST.EQ.'CURSOR') THEN
  12291.           CALL GRQCAP(DEV1)
  12292.           IF (DEV1(2:2).EQ.'N') THEN
  12293.               VALUE = 'NO'
  12294.               LENGTH = 2
  12295.           ELSE
  12296.               VALUE = 'YES'
  12297.               LENGTH = 3
  12298.           END IF
  12299.           IER = 1
  12300.       ELSE
  12301.           IER = 0
  12302.       END IF
  12303.       IF (IER.NE.1) THEN
  12304.          VALUE = '?'
  12305.          LENGTH = 1
  12306.       ELSE IF (LENGTH.LT.1) THEN
  12307.          LENGTH = 1
  12308.          VALUE = ' '
  12309.       END IF
  12310.       END
  12311. C*PGQITF -- inquire image transfer function
  12312. C%void cpgqitf(int *itf);
  12313. C+
  12314.       SUBROUTINE PGQITF (ITF)
  12315.       INTEGER  ITF
  12316. C
  12317. C Return the Image Transfer Function as set by default or by a previous
  12318. C call to PGSITF. The Image Transfer Function is used by routines
  12319. C PGIMAG, PGGRAY, and PGWEDG.
  12320. C
  12321. C Argument:
  12322. C  ITF    (output) : type of transfer function (see PGSITF)
  12323. C--
  12324. C 15-Sep-1994 - new routine [TJP].
  12325. C-----------------------------------------------------------------------
  12326.       INCLUDE 'f77.PGPLOT/IN'
  12327.       LOGICAL PGNOTO
  12328. C
  12329.       IF (PGNOTO('PGQITF')) THEN
  12330.           ITF = 0
  12331.       ELSE
  12332.           ITF = PGITF(PGID)
  12333.       END IF
  12334.       END
  12335. C*PGQLS -- inquire line style
  12336. C%void cpgqls(int *ls);
  12337. C+
  12338.       SUBROUTINE PGQLS (LS)
  12339.       INTEGER  LS
  12340. C
  12341. C Query the current Line Style attribute (set by routine PGSLS).
  12342. C
  12343. C Argument:
  12344. C  LS     (output) : the current line-style attribute (in range 1-5).
  12345. C--
  12346. C  5-Nov-1985 - new routine [TJP].
  12347. C-----------------------------------------------------------------------
  12348.       LOGICAL PGNOTO
  12349. C
  12350.       IF (PGNOTO('PGQLS')) THEN
  12351.          LS = 1
  12352.       ELSE
  12353.          CALL GRQLS(LS)
  12354.       END IF
  12355.       END
  12356. C*PGQLW -- inquire line width
  12357. C%void cpgqlw(int *lw);
  12358. C+
  12359.       SUBROUTINE PGQLW (LW)
  12360.       INTEGER  LW
  12361. C
  12362. C Query the current Line-Width attribute (set by routine PGSLW).
  12363. C
  12364. C Argument:
  12365. C  LW     (output)  : the line-width (in range 1-201).
  12366. C--
  12367. C  5-Nov-1985 - new routine [TJP].
  12368. C-----------------------------------------------------------------------
  12369.       LOGICAL PGNOTO
  12370. C     
  12371.       IF (PGNOTO('PGQLW')) THEN
  12372.          LW = 1
  12373.       ELSE
  12374.          CALL GRQLW(LW)
  12375.       END IF
  12376.       END
  12377. C*PGQPOS -- inquire current pen position
  12378. C%void cpgqpos(float *x, float *y);
  12379. C+
  12380.       SUBROUTINE PGQPOS (X, Y)
  12381.       REAL X, Y
  12382. C
  12383. C Query the current "pen" position in world C coordinates (X,Y).
  12384. C
  12385. C Arguments:
  12386. C  X      (output)  : world x-coordinate of the pen position.
  12387. C  Y      (output)  : world y-coordinate of the pen position.
  12388. C--
  12389. C  1-Mar-1991 - new routine [JM].
  12390. C-----------------------------------------------------------------------
  12391.       CALL GRQPOS(X,Y)
  12392.       END
  12393. C*PGQTBG -- inquire text background color index
  12394. C%void cpgqtbg(int *tbci);
  12395. C+
  12396.       SUBROUTINE PGQTBG (TBCI)
  12397.       INTEGER  TBCI
  12398. C
  12399. C Query the current Text Background Color Index (set by routine
  12400. C PGSTBG).
  12401. C
  12402. C Argument:
  12403. C  TBCI   (output) : receives the current text background color index.
  12404. C--
  12405. C 16-Oct-1993 - new routine [TJP].
  12406. C-----------------------------------------------------------------------
  12407.       INCLUDE 'f77.PGPLOT/IN'
  12408.       LOGICAL PGNOTO
  12409. C
  12410.       IF (PGNOTO('PGQTBG')) THEN
  12411.           TBCI = 0
  12412.       ELSE
  12413.           TBCI = PGTBCI(PGID)
  12414.       END IF
  12415.       END
  12416. C*PGQTXT -- find bounding box of text string
  12417. C%void cpgqtxt(float x, float y, float angle, float fjust, \
  12418. C% const char *text, float *xbox, float *ybox);
  12419. C+
  12420.       SUBROUTINE PGQTXT (X, Y, ANGLE, FJUST, TEXT, XBOX, YBOX)
  12421.       REAL X, Y, ANGLE, FJUST
  12422.       CHARACTER*(*) TEXT
  12423.       REAL XBOX(4), YBOX(4)
  12424. C
  12425. C This routine returns a bounding box for a text string. Instead
  12426. C of drawing the string as routine PGPTXT does, it returns in XBOX
  12427. C and YBOX the coordinates of the corners of a rectangle parallel
  12428. C to the string baseline that just encloses the string.
  12429. C
  12430. C If the string is blank or contains no drwable characters, all
  12431. C four elements of XBOX and YBOX are assigned the starting point
  12432. C of the string, (X,Y).
  12433. C
  12434. C Arguments:
  12435. C  X, Y, ANGLE, FJUST, TEXT (input) : these arguments are the same as
  12436. C                    the corrresponding arguments in PGPTXT.
  12437. C  XBOX, YBOX (output) : arrays of dimension 4; on output, they
  12438. C                    contain the world coordinates of the bounding
  12439. C                    box in (XBOX(1), YBOX(1)), ..., (XBOX(4), YBOX(4)).
  12440. C--
  12441. C 12-Sep-1993 - new routine [TJP].
  12442. C  8-Nov-1994 - return something for blank string [TJP].
  12443. C-----------------------------------------------------------------------
  12444.       INCLUDE 'f77.PGPLOT/IN'
  12445.       LOGICAL PGNOTO
  12446.       INTEGER I, L, GRTRIM
  12447.       REAL D, XP, YP, XPBOX(4), YPBOX(4), XOFFS, YOFFS
  12448. C
  12449.       IF (PGNOTO('PGQTXT')) RETURN
  12450. C
  12451.       L = GRTRIM(TEXT)
  12452.       IF (L.LE.0) THEN
  12453.          DO 15 I=1,4
  12454.             XBOX(I) = X
  12455.             YBOX(I) = Y
  12456.  15      CONTINUE
  12457.       ELSE
  12458.          D = 0.0
  12459.          IF (FJUST.NE.0.0) CALL GRLEN(TEXT(1:L),D)
  12460.          XOFFS = PGXORG(PGID) - D*FJUST*COS(ANGLE/57.29578)
  12461.          YOFFS = PGYORG(PGID) - D*FJUST*SIN(ANGLE/57.29578)
  12462.          XP = X*PGXSCL(PGID) + XOFFS
  12463.          YP = Y*PGYSCL(PGID) + YOFFS
  12464.          CALL GRQTXT(ANGLE, XP, YP, TEXT(1:L), XPBOX, YPBOX)
  12465.          DO 25 I=1,4
  12466.             XBOX(I) = (XPBOX(I) - PGXORG(PGID))/PGXSCL(PGID)
  12467.             YBOX(I) = (YPBOX(I) - PGYORG(PGID))/PGYSCL(PGID)
  12468.  25      CONTINUE
  12469.       END IF
  12470.       END
  12471. C*PGQVP -- inquire viewport size and position
  12472. C%void cpgqvp(int units, float *x1, float *x2, float *y1, float *y2);
  12473. C+
  12474.       SUBROUTINE PGQVP (UNITS, X1, X2, Y1, Y2)
  12475.       INTEGER UNITS
  12476.       REAL    X1, X2, Y1, Y2
  12477. C
  12478. C Inquiry routine to determine the current viewport setting.
  12479. C The values returned may be normalized device coordinates, inches, mm,
  12480. C or pixels, depending on the value of the input parameter CFLAG.
  12481. C
  12482. C Arguments:
  12483. C  UNITS  (input)  : used to specify the units of the output parameters:
  12484. C                    UNITS = 0 : normalized device coordinates
  12485. C                    UNITS = 1 : inches
  12486. C                    UNITS = 2 : millimeters
  12487. C                    UNITS = 3 : pixels
  12488. C                    Other values give an error message, and are
  12489. C                    treated as 0.
  12490. C  X1     (output) : the x-coordinate of the bottom left corner of the
  12491. C                    viewport.
  12492. C  X2     (output) : the x-coordinate of the top right corner of the
  12493. C                    viewport.
  12494. C  Y1     (output) : the y-coordinate of the bottom left corner of the
  12495. C                    viewport.
  12496. C  Y2     (output) : the y-coordinate of the top right corner of the
  12497. C                    viewport.
  12498. C--
  12499. C 26-Sep-1985 - new routine (TJP).
  12500. C-----------------------------------------------------------------------
  12501.       INCLUDE 'f77.PGPLOT/IN'
  12502.       REAL SX, SY
  12503. C
  12504.       IF (UNITS.EQ.0) THEN
  12505.           SX = PGXSZ(PGID)
  12506.           SY = PGYSZ(PGID)
  12507.       ELSE IF (UNITS.EQ.1) THEN
  12508.           SX = PGXPIN(PGID)
  12509.           SY = PGYPIN(PGID)
  12510.       ELSE IF (UNITS.EQ.2) THEN
  12511.           SX = (PGXPIN(PGID)/25.4)
  12512.           SY = (PGYPIN(PGID)/25.4)
  12513.       ELSE IF (UNITS.EQ.3) THEN
  12514.           SX = 1.0
  12515.           SY = 1.0
  12516.       ELSE
  12517.           CALL GRWARN(
  12518.      1        'Illegal value for parameter UNITS in routine PGQVP')
  12519.           SX = PGXSZ(PGID)
  12520.           SY = PGYSZ(PGID)
  12521.       END IF
  12522.       X1 = PGXVP(PGID)/SX
  12523.       X2 = (PGXVP(PGID)+PGXLEN(PGID))/SX
  12524.       Y1 = PGYVP(PGID)/SY
  12525.       Y2 = (PGYVP(PGID)+PGYLEN(PGID))/SY
  12526.       END
  12527. C*PGQVSZ -- find the window defined by the full view surface
  12528. C%void cpgqvsz(int units, float *x1, float *x2, float *y1, float *y2);
  12529. C+
  12530.       SUBROUTINE PGQVSZ (UNITS, X1, X2, Y1, Y2)
  12531.       INTEGER UNITS
  12532.       REAL X1, X2, Y1, Y2
  12533. C
  12534. C Return the window, in a variety of units, defined by the full
  12535. C device view surface (0 -> 1 in normalized device coordinates).
  12536. C
  12537. C Input:
  12538. C   UNITS    0,1,2,3 for output in normalized device coords, 
  12539. C            inches, mm, or absolute device units (dots)
  12540. C Output
  12541. C   X1,X2    X window
  12542. C   Y1,Y2    Y window
  12543. C
  12544. C--
  12545. C 28-Aug-92 - new routine (Neil Killeen)
  12546. C  2-Dec-92 - changed to avoid resetting the viewport (TJP).
  12547. C-----------------------------------------------------------------------
  12548.       INCLUDE 'f77.PGPLOT/IN'
  12549.       REAL SX, SY
  12550. C
  12551.       IF (UNITS.EQ.0) THEN
  12552.           SX = PGXSZ(PGID)
  12553.           SY = PGYSZ(PGID)
  12554.       ELSE IF (UNITS.EQ.1) THEN
  12555.           SX = PGXPIN(PGID)
  12556.           SY = PGYPIN(PGID)
  12557.       ELSE IF (UNITS.EQ.2) THEN
  12558.           SX = (PGXPIN(PGID)/25.4)
  12559.           SY = (PGYPIN(PGID)/25.4)
  12560.       ELSE IF (UNITS.EQ.3) THEN
  12561.           SX = 1.0
  12562.           SY = 1.0
  12563.       ELSE
  12564.           CALL GRWARN(
  12565.      1        'Illegal value for parameter UNITS in routine PGQVSZ')
  12566.           SX = PGXSZ(PGID)
  12567.           SY = PGYSZ(PGID)
  12568.       END IF
  12569.       X1 = 0.0
  12570.       X2 = PGXSZ(PGID)/SX
  12571.       Y1 = 0.0
  12572.       Y2 = PGYSZ(PGID)/SY
  12573.       END
  12574. C*PGQWIN -- inquire window boundary coordinates
  12575. C%void cpgqwin(float *x1, float *x2, float *y1, float *y2);
  12576. C+
  12577.       SUBROUTINE PGQWIN (X1, X2, Y1, Y2)
  12578.       REAL X1, X2, Y1, Y2
  12579. C
  12580. C Inquiry routine to determine the current window setting.
  12581. C The values returned are world coordinates.
  12582. C
  12583. C Arguments:
  12584. C  X1     (output) : the x-coordinate of the bottom left corner
  12585. C                    of the window.
  12586. C  X2     (output) : the x-coordinate of the top right corner
  12587. C                    of the window.
  12588. C  Y1     (output) : the y-coordinate of the bottom left corner
  12589. C                    of the window.
  12590. C  Y2     (output) : the y-coordinate of the top right corner
  12591. C                    of the window.
  12592. C--
  12593. C 26-Sep-1985 - new routine (TJP).
  12594. C-----------------------------------------------------------------------
  12595.       INCLUDE 'f77.PGPLOT/IN'
  12596. C
  12597.       X1 = PGXBLC(PGID)
  12598.       X2 = PGXTRC(PGID)
  12599.       Y1 = PGYBLC(PGID)
  12600.       Y2 = PGYTRC(PGID)
  12601.       END
  12602. C*PGRECT -- draw a rectangle, using fill-area attributes
  12603. C%void cpgrect(float x1, float x2, float y1, float y2);
  12604. C+
  12605.       SUBROUTINE PGRECT (X1, X2, Y1, Y2)
  12606.       REAL X1, X2, Y1, Y2
  12607. C
  12608. C This routine can be used instead of PGPOLY for the special case of
  12609. C drawing a rectangle aligned with the coordinate axes; only two
  12610. C vertices need be specified instead of four.  On most devices, it is
  12611. C faster to use PGRECT than PGPOLY for drawing rectangles.  The
  12612. C rectangle has vertices at (X1,Y1), (X1,Y2), (X2,Y2), and (X2,Y1).
  12613. C
  12614. C Arguments:
  12615. C  X1, X2 (input) : the horizontal range of the rectangle.
  12616. C  Y1, Y2 (input) : the vertical range of the rectangle.
  12617. C--
  12618. C 21-Nov-1986 - [TJP].
  12619. C 22-Mar-1988 - use GRRECT for fill [TJP].
  12620. C  6-Mar-1995 - add hatching (by calling PGHTCH) [TJP].
  12621. C-----------------------------------------------------------------------
  12622.       INCLUDE  'f77.PGPLOT/IN'
  12623.       REAL XP(4), YP(4)
  12624. C
  12625.       CALL PGBBUF
  12626. C
  12627. C Outline only.
  12628. C
  12629.       IF (PGFAS(PGID).EQ.2) THEN
  12630.          CALL GRMOVA(X1,Y1)
  12631.          CALL GRLINA(X1,Y2)
  12632.          CALL GRLINA(X2,Y2)
  12633.          CALL GRLINA(X2,Y1)
  12634.          CALL GRLINA(X1,Y1)
  12635. C
  12636. C Hatching.
  12637. C
  12638.       ELSE IF (PGFAS(PGID).EQ.3 .OR. PGFAS(PGID).EQ.4) THEN
  12639.          XP(1) = X1
  12640.          XP(2) = X1
  12641.          XP(3) = X2
  12642.          XP(4) = X2
  12643.          YP(1) = Y1
  12644.          YP(2) = Y2
  12645.          YP(3) = Y2
  12646.          YP(4) = Y1
  12647.          CALL PGHTCH(4, XP, YP, 0.0)
  12648.          IF (PGFAS(PGID).EQ.4) CALL PGHTCH(4, XP, YP, 90.0)
  12649. C
  12650. C Solid fill.
  12651. C
  12652.       ELSE
  12653.           CALL GRRECT(X1,Y1,X2,Y2)
  12654.           CALL GRMOVA(X1,Y1)
  12655.       END IF
  12656.       CALL PGEBUF
  12657.       END
  12658. C*PGRND -- find the smallest `round' number greater than x
  12659. C%float cpgrnd(float x, int *nsub);
  12660. C+
  12661.       REAL FUNCTION PGRND (X, NSUB)
  12662.       REAL X
  12663.       INTEGER NSUB
  12664. C
  12665. C Routine to find the smallest "round" number larger than x, a
  12666. C "round" number being 1, 2 or 5 times a power of 10. If X is negative,
  12667. C PGRND(X) = -PGRND(ABS(X)). eg PGRND(8.7) = 10.0,
  12668. C PGRND(-0.4) = -0.5.  If X is zero, the value returned is zero.
  12669. C This routine is used by PGBOX for choosing  tick intervals.
  12670. C
  12671. C Returns:
  12672. C  PGRND         : the "round" number.
  12673. C Arguments:
  12674. C  X      (input)  : the number to be rounded.
  12675. C  NSUB   (output) : a suitable number of subdivisions for
  12676. C                    subdividing the "nice" number: 2 or 5.
  12677. C--
  12678. C  6-Sep-1989 - Changes for standard Fortran-77 [TJP].
  12679. C  2-Dec-1991 - Fix for bug found on Fujitsu [TJP].
  12680. C-----------------------------------------------------------------------
  12681.       INTEGER  I,ILOG
  12682.       REAL     FRAC,NICE(3),PWR,XLOG,XX
  12683.       INTRINSIC ABS, LOG10, SIGN
  12684.       DATA     NICE/2.0,5.0,10.0/
  12685. C
  12686.       IF (X.EQ.0.0) THEN
  12687.           PGRND = 0.0
  12688.           NSUB = 2
  12689.           RETURN
  12690.       END IF
  12691.       XX   = ABS(X)
  12692.       XLOG = LOG10(XX)
  12693.       ILOG = XLOG
  12694.       IF (XLOG.LT.0) ILOG=ILOG-1
  12695.       PWR  = 10.0**ILOG
  12696.       FRAC = XX/PWR
  12697.       I = 3
  12698.       IF (FRAC.LE.NICE(2)) I = 2
  12699.       IF (FRAC.LE.NICE(1)) I = 1
  12700.       PGRND = SIGN(PWR*NICE(I),X)
  12701.       NSUB = 5
  12702.       IF (I.EQ.1) NSUB = 2
  12703.       END
  12704. C*PGRNGE -- choose axis limits
  12705. C%void cpgrnge(float x1, float x2, float *xlo, float *xhi);
  12706. C+
  12707.       SUBROUTINE PGRNGE (X1, X2, XLO, XHI)
  12708.       REAL X1, X2, XLO, XHI
  12709. C
  12710. C Choose plotting limits XLO and XHI which encompass the data
  12711. C range X1 to X2.
  12712. C
  12713. C Arguments:
  12714. C  X1, X2 (input)  : the data range (X1<X2), ie, the min and max values
  12715. C                    to be plotted.
  12716. C  XLO, XHI (output) : suitable values to use as the extremes of a graph
  12717. C                    axis (XLO <= X1, XHI >= X2).
  12718. C--
  12719. C 10-Nov-1985 - new routine [TJP].
  12720. C-----------------------------------------------------------------------
  12721.       XLO = X1 - 0.1*(X2-X1)
  12722.       XHI = X2 + 0.1*(X2-X1)
  12723.       IF (XLO.LT.0.0 .AND. X1.GE.0.0) XLO = 0.0
  12724.       IF (XHI.GT.0.0 .AND. X2.LE.0.0) XHI = 0.0
  12725.       END
  12726. C*PGSAH -- set arrow-head style
  12727. C%void cpgsah(int fs, float angle, float vent);
  12728. C+
  12729.       SUBROUTINE PGSAH (FS, ANGLE, VENT)
  12730.       INTEGER  FS
  12731.       REAL ANGLE, VENT
  12732. C
  12733. C Set the style to be used for arrowheads drawn with routine PGARRO.
  12734. C
  12735. C Argument:
  12736. C  FS     (input)  : FS = 1 => filled; FS = 2 => outline.
  12737. C                    Other values are treated as 2. Default 1.
  12738. C  ANGLE  (input)  : the acute angle of the arrow point, in degrees;
  12739. C                    angles in the range 20.0 to 90.0 give reasonable
  12740. C                    results. Default 45.0.
  12741. C  VENT   (input)  : the fraction of the triangular arrow-head that
  12742. C                    is cut away from the back. 0.0 gives a triangular
  12743. C                    wedge arrow-head; 1.0 gives an open >. Values 0.3
  12744. C                    to 0.7 give reasonable results. Default 0.3.
  12745. C--
  12746. C 13-Oct-1992 - new routine [TJP].
  12747. C-----------------------------------------------------------------------
  12748.       INCLUDE 'f77.PGPLOT/IN'
  12749. C
  12750.       PGAHS(PGID) = FS
  12751.       IF (PGAHS(PGID).NE.1) PGAHS(PGID) = 2
  12752.       PGAHA(PGID) = ANGLE
  12753.       PGAHV(PGID) = VENT
  12754. C
  12755.       END
  12756. C*PGSAVE -- save PGPLOT attributes
  12757. C%void cpgsave(void);
  12758. C+
  12759.       SUBROUTINE PGSAVE
  12760. C
  12761. C This routine saves the current PGPLOT attributes in a private storage
  12762. C area. They can be restored by calling PGUNSA (unsave). Attributes
  12763. C saved are: character font, character height, color index, fill-area
  12764. C style, line style, line width, pen position, arrow-head style, 
  12765. C hatching style. Color representation is not saved.
  12766. C
  12767. C Calls to PGSAVE and PGUNSA should always be paired. Up to 20 copies
  12768. C of the attributes may be saved. PGUNSA always retrieves the last-saved
  12769. C values (last-in first-out stack).
  12770. C
  12771. C Note that when multiple devices are in use, PGUNSA retrieves the
  12772. C values saved by the last PGSAVE call, even if they were for a
  12773. C different device.
  12774. C
  12775. C Arguments: none
  12776. C--
  12777. C 20-Apr-1992 - new routine [TJP].
  12778. C 27-Nov-1992 - add arrowhead style [TJP].
  12779. C  6-Oct-1993 - add text opacity [TJP].
  12780. C 28-Feb-1994 - correct bug (variable not saved) [TJP].
  12781. C 26-Feb-1995 - add hatching attributes.
  12782. C 19-Jun-1996 - correction in header comments [TJP].
  12783. C-----------------------------------------------------------------------
  12784.       INTEGER MAXS
  12785.       PARAMETER (MAXS=20)
  12786. C
  12787.       INTEGER LEV
  12788.       INTEGER CF(MAXS), CI(MAXS), FS(MAXS), LS(MAXS), LW(MAXS)
  12789.       INTEGER AHFS(MAXS), TBG(MAXS)
  12790.       REAL    CH(MAXS), POS(2,MAXS)
  12791.       REAL    AHANG(MAXS), AHVENT(MAXS), HSA(MAXS), HSS(MAXS), HSP(MAXS)
  12792.       SAVE    LEV, CF, CI, FS, LS, LW, AHFS, TBG, CH, POS
  12793.       SAVE    AHANG, AHVENT, HSA, HSS, HSP
  12794.       DATA    LEV /0/
  12795. C
  12796.       IF (LEV.GE.MAXS) THEN
  12797.           CALL GRWARN('Too many unmatched calls to PGSAVE')
  12798.       ELSE
  12799.           LEV = LEV+1
  12800.           CALL PGQCF(CF(LEV))
  12801.           CALL PGQCH(CH(LEV))
  12802.           CALL PGQCI(CI(LEV))
  12803.           CALL PGQFS(FS(LEV))
  12804.           CALL PGQLS(LS(LEV))
  12805.           CALL PGQLW(LW(LEV))
  12806. C          CALL PGQVP(0, VP(1,LEV), VP(2,LEV), VP(3,LEV), VP(4,LEV))
  12807. C          CALL PGQWIN(WIN(1,LEV), WIN(2,LEV), WIN(3,LEV), WIN(4,LEV))
  12808.           CALL PGQPOS(POS(1,LEV), POS(2,LEV))
  12809.           CALL PGQAH(AHFS(LEV), AHANG(LEV), AHVENT(LEV))
  12810.           CALL PGQTBG(TBG(LEV))
  12811.           CALL PGQHS(HSA(LEV), HSS(LEV), HSP(LEV))
  12812.       END IF
  12813.       RETURN     
  12814. C
  12815. C*PGUNSA -- restore PGPLOT attributes
  12816. C%void cpgunsa(void);
  12817. C+
  12818.       ENTRY PGUNSA
  12819. C
  12820. C This routine restores the PGPLOT attributes saved in the last call to
  12821. C PGSAVE. Usage: CALL PGUNSA (no arguments). See PGSAVE.
  12822. C
  12823. C Arguments: none
  12824. C-----------------------------------------------------------------------
  12825.       IF (LEV.LE.0) THEN
  12826.           CALL GRWARN('PGUNSA: nothing has been saved')
  12827.       ELSE
  12828.           CALL PGSCF(CF(LEV))
  12829.           CALL PGSCH(CH(LEV))
  12830.           CALL PGSCI(CI(LEV))
  12831.           CALL PGSFS(FS(LEV))
  12832.           CALL PGSLS(LS(LEV))
  12833.           CALL PGSLW(LW(LEV))
  12834. C          CALL PGSVP(VP(1,LEV), VP(2,LEV), VP(3,LEV), VP(4,LEV))
  12835. C          CALL PGSWIN(WIN(1,LEV), WIN(2,LEV), WIN(3,LEV), WIN(4,LEV))
  12836.           CALL PGMOVE(POS(1,LEV), POS(2,LEV))
  12837.           CALL PGSAH(AHFS(LEV), AHANG(LEV), AHVENT(LEV))
  12838.           CALL PGSTBG(TBG(LEV))
  12839.           CALL PGSHS(HSA(LEV), HSS(LEV), HSP(LEV))
  12840.           LEV = LEV-1
  12841.       END IF
  12842.       RETURN     
  12843.       END
  12844. C*PGSCF -- set character font
  12845. C%void cpgscf(int font);
  12846. C+
  12847.       SUBROUTINE PGSCF (FONT)
  12848.       INTEGER  FONT
  12849. C
  12850. C Set the Character Font for subsequent text plotting. Four different
  12851. C fonts are available:
  12852. C   1: (default) a simple single-stroke font ("normal" font)
  12853. C   2: roman font
  12854. C   3: italic font
  12855. C   4: script font
  12856. C This call determines which font is in effect at the beginning of
  12857. C each text string. The font can be changed (temporarily) within a text
  12858. C string by using the escape sequences \fn, \fr, \fi, and \fs for fonts
  12859. C 1, 2, 3, and 4, respectively.
  12860. C
  12861. C Argument:
  12862. C  FONT   (input)  : the font number to be used for subsequent text
  12863. C                    plotting (in range 1-4).
  12864. C--
  12865. C 26-Sep-1985 - new routine [TJP].
  12866. C 25-OCT-1993 - changed name of argument [TJP].
  12867. C-----------------------------------------------------------------------
  12868.       LOGICAL PGNOTO
  12869. C
  12870.       IF (PGNOTO('PGSCF')) RETURN
  12871.       CALL GRSFNT(FONT)
  12872.       END
  12873. C*PGSCH -- set character height
  12874. C%void cpgsch(float size);
  12875. C+
  12876.       SUBROUTINE PGSCH (SIZE)
  12877.       REAL SIZE
  12878. C
  12879. C Set the character size attribute. The size affects all text and graph
  12880. C markers drawn later in the program. The default character size is
  12881. C 1.0, corresponding to a character height about 1/40 the height of
  12882. C the view surface.  Changing the character size also scales the length
  12883. C of tick marks drawn by PGBOX and terminals drawn by PGERRX and PGERRY.
  12884. C
  12885. C Argument:
  12886. C  SIZE   (input)  : new character size (dimensionless multiple of
  12887. C                    the default size).
  12888. C--
  12889. C (1-Mar-1983)
  12890. C-----------------------------------------------------------------------
  12891.       INCLUDE  'f77.PGPLOT/IN'
  12892.       LOGICAL  PGNOTO
  12893.       REAL     XC, XCNEW, YC, XS, YS
  12894. C
  12895.       IF (PGNOTO('PGSCH')) RETURN
  12896. C
  12897.       CALL GRCHSZ(PGID, XC, YC, XS, YS)
  12898.       IF (PGXSZ(PGID)/PGXPIN(PGID) .GT.
  12899.      1    PGYSZ(PGID)/PGYPIN(PGID)) THEN
  12900.           XCNEW = SIZE*XC*PGYSZ(PGID)/YS/40.0
  12901.       ELSE
  12902.           XCNEW = SIZE*XC*(PGXSZ(PGID)*PGYPIN(PGID)/PGXPIN(PGID))
  12903.      1            /YS/40.0
  12904.       END IF
  12905.       CALL GRSETC(PGID,XCNEW)
  12906.       PGXSP(PGID) = XS*XCNEW/XC
  12907.       PGYSP(PGID) = YS*XCNEW/XC
  12908.       PGCHSZ(PGID) = SIZE
  12909.       END
  12910. C*PGSCI -- set color index
  12911. C%void cpgsci(int ci);
  12912. C+
  12913.       SUBROUTINE PGSCI (CI)
  12914.       INTEGER  CI
  12915. C
  12916. C Set the Color Index for subsequent plotting, if the output device
  12917. C permits this. The default color index is 1, usually white on a black
  12918. C background for video displays or black on a white background for
  12919. C printer plots. The color index is an integer in the range 0 to a
  12920. C device-dependent maximum. Color index 0 corresponds to the background
  12921. C color; lines may be "erased" by overwriting them with color index 0
  12922. C (if the device permits this).
  12923. C
  12924. C If the requested color index is not available on the selected device,
  12925. C color index 1 will be substituted.
  12926. C
  12927. C The assignment of colors to color indices can be changed with
  12928. C subroutine PGSCR (set color representation).  Color indices 0-15
  12929. C have predefined color representations (see the PGPLOT manual), but
  12930. C these may be changed with PGSCR.  Color indices above 15  have no
  12931. C predefined representations: if these indices are used, PGSCR must
  12932. C be called to define the representation.
  12933. C
  12934. C Argument:
  12935. C  CI     (input)  : the color index to be used for subsequent plotting
  12936. C                    on the current device (in range 0-max). If the
  12937. C                    index exceeds the device-dependent maximum, the
  12938. C                    default color index (1) is used.
  12939. C--
  12940. C 26-Sep-1985 - new routine [TJP].
  12941. C-----------------------------------------------------------------------
  12942.       LOGICAL PGNOTO
  12943. C
  12944.       IF (PGNOTO('PGSCI')) RETURN
  12945.       CALL GRSCI(CI)
  12946.       END
  12947. C*PGSCIR -- set color index range
  12948. C%void cpgscir(int icilo, int icihi);
  12949. C+
  12950.       SUBROUTINE PGSCIR(ICILO, ICIHI)
  12951.       INTEGER   ICILO, ICIHI
  12952. C
  12953. C Set the color index range to be used for producing images with
  12954. C PGGRAY or PGIMAG. If the range is not all within the range supported
  12955. C by the device, a smaller range will be used. The number of
  12956. C different colors available for images is ICIHI-ICILO+1.
  12957. C
  12958. C Arguments:
  12959. C  ICILO  (input)  : the lowest color index to use for images
  12960. C  ICIHI  (input)  : the highest color index to use for images
  12961. C--
  12962. C 1994-Mar-17 : new routine [AFT/TJP].
  12963. C---
  12964.       INCLUDE 'f77.PGPLOT/IN'
  12965.       INTEGER IC1, IC2
  12966. C---
  12967.       CALL GRQCOL(IC1,IC2)
  12968.       PGMNCI(PGID) = MIN(IC2,MAX(IC1,ICILO))
  12969.       PGMXCI(PGID) = MIN(IC2,MAX(IC1,ICIHI))
  12970. C
  12971.       END
  12972. C*PGSCR -- set color representation
  12973. C%void cpgscr(int ci, float cr, float cg, float cb);
  12974. C+
  12975.       SUBROUTINE PGSCR (CI, CR, CG, CB)
  12976.       INTEGER CI
  12977.       REAL    CR, CG, CB
  12978. C
  12979. C Set color representation: i.e., define the color to be
  12980. C associated with a color index.  Ignored for devices which do not
  12981. C support variable color or intensity.  Color indices 0-15
  12982. C have predefined color representations (see the PGPLOT manual), but
  12983. C these may be changed with PGSCR.  Color indices 16-maximum have no
  12984. C predefined representations: if these indices are used, PGSCR must
  12985. C be called to define the representation. On monochrome output
  12986. C devices (e.g. VT125 terminals with monochrome monitors), the
  12987. C monochrome intensity is computed from the specified Red, Green, Blue
  12988. C intensities as 0.30*R + 0.59*G + 0.11*B, as in US color television
  12989. C systems, NTSC encoding.  Note that most devices do not have an
  12990. C infinite range of colors or monochrome intensities available;
  12991. C the nearest available color is used.  Examples: for black,
  12992. C set CR=CG=CB=0.0; for white, set CR=CG=CB=1.0; for medium gray,
  12993. C set CR=CG=CB=0.5; for medium yellow, set CR=CG=0.5, CB=0.0.
  12994. C
  12995. C Argument:
  12996. C  CI     (input)  : the color index to be defined, in the range 0-max.
  12997. C                    If the color index greater than the device
  12998. C                    maximum is specified, the call is ignored. Color
  12999. C                    index 0 applies to the background color.
  13000. C  CR     (input)  : red, green, and blue intensities,
  13001. C  CG     (input)    in range 0.0 to 1.0.
  13002. C  CB     (input)
  13003. C--
  13004. C 5-Nov-1985 - new routine [TJP].
  13005. C-----------------------------------------------------------------------
  13006.       LOGICAL PGNOTO
  13007. C
  13008.       IF (PGNOTO('PGSCR')) RETURN
  13009.       CALL GRSCR(CI,CR,CG,CB)
  13010.       END
  13011. C*PGSCRN -- set color representation by name
  13012. C%void cpgscrn(int ci, const char *name, int *ier);
  13013. C+
  13014.       SUBROUTINE PGSCRN(CI, NAME, IER)
  13015.       INTEGER CI
  13016.       CHARACTER*(*) NAME
  13017.       INTEGER IER
  13018. C
  13019. C Set color representation: i.e., define the color to be
  13020. C associated with a color index.  Ignored for devices which do not
  13021. C support variable color or intensity.  This is an alternative to
  13022. C routine PGSCR. The color representation is defined by name instead
  13023. C of (R,G,B) components.
  13024. C
  13025. C Color names are defined in an external file which is read the first
  13026. C time that PGSCRN is called. The name of the external file is
  13027. C found as follows:
  13028. C 1. if environment variable (logical name) PGPLOT_RGB is defined,
  13029. C    its value is used as the file name;
  13030. C 2. otherwise, if environment variable PGPLOT_DIR is defined, a
  13031. C    file "rgb.txt" in the directory named by this environment
  13032. C    variable is used;
  13033. C 3. otherwise, file "rgb.txt" in the current directory is used.
  13034. C If all of these fail to find a file, an error is reported and
  13035. C the routine does nothing.
  13036. C
  13037. C Each line of the file
  13038. C defines one color, with four blank- or tab-separated fields per
  13039. C line. The first three fields are the R, G, B components, which
  13040. C are integers in the range 0 (zero intensity) to 255 (maximum
  13041. C intensity). The fourth field is the color name. The color name
  13042. C may include embedded blanks. Example:
  13043. C
  13044. C 255   0   0 red
  13045. C 255 105 180 hot pink
  13046. C 255 255 255 white
  13047. C   0   0   0 black
  13048. C
  13049. C Arguments:
  13050. C  CI     (input)  : the color index to be defined, in the range 0-max.
  13051. C                    If the color index greater than the device
  13052. C                    maximum is specified, the call is ignored. Color
  13053. C                    index 0 applies to the background color.
  13054. C  NAME   (input)  : the name of the color to be associated with
  13055. C                    this color index. This name must be in the
  13056. C                    external file. The names are not case-sensitive.
  13057. C                    If the color is not listed in the file, the
  13058. C                    color representation is not changed.
  13059. C  IER    (output) : returns 0 if the routine was successful, 1
  13060. C                    if an error occurred (either the external file
  13061. C                    could not be read, or the requested color was
  13062. C                    not defined in the file).
  13063. C--
  13064. C 12-Oct-1992 [TJP]
  13065. C 31-May-1993 [TJP] use GROPTX to open file.
  13066. C  7-Nov-1994 [TJP] better error messages.
  13067. C-----------------------------------------------------------------------
  13068.       INTEGER MAXCOL
  13069.       PARAMETER (MAXCOL=1000)
  13070.       INTEGER I, IR, IG, IB, J, L, NCOL, UNIT, IOS
  13071.       INTEGER GRCTOI, GROPTX, GRTRIM
  13072.       REAL RR(MAXCOL), RG(MAXCOL), RB(MAXCOL)
  13073.       CHARACTER*20 CREQ, CNAME(MAXCOL)
  13074.       CHARACTER*255 TEXT
  13075.       SAVE NCOL, CNAME, RR, RG, RB
  13076.       DATA NCOL/0/
  13077. C
  13078. C On first call, read the database.
  13079. C
  13080.       IF (NCOL.EQ.0) THEN
  13081.           CALL GRGFIL('RGB', TEXT)
  13082.           L = GRTRIM(TEXT)
  13083.           IF (L.LT.1) L = 1
  13084.           CALL GRGLUN(UNIT)
  13085.           IOS = GROPTX(UNIT, TEXT(1:L), 'rgb.txt', 0)
  13086.           IF (IOS.NE.0) GOTO 40
  13087.           DO 10 I=1,MAXCOL
  13088.               READ (UNIT, '(A)', ERR=15, END=15) TEXT
  13089.               J = 1
  13090.               CALL GRSKPB(TEXT, J)
  13091.               IR = GRCTOI(TEXT, J)
  13092.               CALL GRSKPB(TEXT, J)
  13093.               IG = GRCTOI(TEXT, J)
  13094.               CALL GRSKPB(TEXT, J)
  13095.               IB = GRCTOI(TEXT, J)
  13096.               CALL GRSKPB(TEXT, J)
  13097.               NCOL = NCOL+1
  13098.               CALL GRTOUP(CNAME(NCOL), TEXT(J:))
  13099.               RR(NCOL) = IR/255.0
  13100.               RG(NCOL) = IG/255.0
  13101.               RB(NCOL) = IB/255.0
  13102.    10     CONTINUE
  13103.    15     CLOSE (UNIT)
  13104.           CALL GRFLUN(UNIT)
  13105.       END IF
  13106. C
  13107. C Look up requested color and set color representation if found.
  13108. C
  13109.       CALL GRTOUP(CREQ, NAME)
  13110.       DO 20 I=1,NCOL
  13111.           IF (CREQ.EQ.CNAME(I)) THEN
  13112.               CALL PGSCR(CI, RR(I), RG(I), RB(I))
  13113.               IER = 0
  13114.               RETURN
  13115.           END IF
  13116.    20 CONTINUE
  13117. C
  13118. C Color not found.
  13119. C
  13120.       IER = 1
  13121.       TEXT = 'Color not found: '//NAME
  13122.       CALL GRWARN(TEXT)
  13123.       RETURN
  13124. C
  13125. C Database not found.
  13126. C
  13127.    40 IER = 1
  13128.       NCOL = -1
  13129.       CALL GRFLUN(UNIT)
  13130.       CALL GRWARN('Unable to read color file: '//TEXT(1:L))
  13131.       CALL GRWARN('Use environment variable PGPLOT_RGB to specify '//
  13132.      :            'the location of the PGPLOT rgb.txt file.')
  13133.       RETURN
  13134.       END
  13135. C
  13136.       SUBROUTINE PGSETC (SIZE)
  13137.       REAL SIZE
  13138.       CALL PGSCH(SIZE)
  13139.       END
  13140. C*PGSFS -- set fill-area style
  13141. C%void cpgsfs(int fs);
  13142. C+
  13143.       SUBROUTINE PGSFS (FS)
  13144.       INTEGER  FS
  13145. C
  13146. C Set the Fill-Area Style attribute for subsequent area-fill by
  13147. C PGPOLY, PGRECT, or PGCIRC.  Four different styles are available: 
  13148. C solid (fill polygon with solid color of the current color-index), 
  13149. C outline (draw outline of polygon only, using current line attributes),
  13150. C hatched (shade interior of polygon with parallel lines, using
  13151. C current line attributes), or cross-hatched. The orientation and
  13152. C spacing of hatch lines can be specified with routine PGSHS (set
  13153. C hatch style).
  13154. C
  13155. C Argument:
  13156. C  FS     (input)  : the fill-area style to be used for subsequent
  13157. C                    plotting:
  13158. C                      FS = 1 => solid (default)
  13159. C                      FS = 2 => outline
  13160. C                      FS = 3 => hatched
  13161. C                      FS = 4 => cross-hatched
  13162. C                    Other values give an error message and are
  13163. C                    treated as 2.
  13164. C--
  13165. C 21-Oct-1985 - new routine [TJP].
  13166. C 17-Dec-1990 - pass to GR level [TJP].
  13167. C  6-Mar-1995 - add styles 3 and 4 [TJP].
  13168. C-----------------------------------------------------------------------
  13169.       INCLUDE 'f77.PGPLOT/IN'
  13170.       LOGICAL PGNOTO
  13171. C
  13172.       IF (PGNOTO('PGSFS')) RETURN
  13173.       IF (FS.LT.1 .OR. FS.GT.4) THEN
  13174.           CALL GRWARN('illegal fill-area style requested')
  13175.           PGFAS(PGID) = 2
  13176.       ELSE
  13177.           PGFAS(PGID) = FS
  13178.       END IF
  13179.       END
  13180. C*PGSHLS -- set color representation using HLS system
  13181. C%void cpgshls(int ci, float ch, float cl, float cs);
  13182. C+
  13183.       SUBROUTINE PGSHLS (CI, CH, CL, CS)
  13184.       INTEGER CI
  13185.       REAL    CH, CL, CS
  13186. C
  13187. C Set color representation: i.e., define the color to be
  13188. C associated with a color index.  This routine is equivalent to
  13189. C PGSCR, but the color is defined in the Hue-Lightness-Saturation
  13190. C model instead of the Red-Green-Blue model. Hue is represented
  13191. C by an angle in degrees, with red at 120, green at 240,
  13192. C and blue at 0 (or 360). Lightness ranges from 0.0 to 1.0, with black
  13193. C at lightness 0.0 and white at lightness 1.0. Saturation ranges from
  13194. C 0.0 (gray) to 1.0 (pure color). Hue is irrelevant when saturation
  13195. C is 0.0.
  13196. C
  13197. C Examples:           H     L     S        R     G     B
  13198. C     black          any   0.0   0.0      0.0   0.0   0.0
  13199. C     white          any   1.0   0.0      1.0   1.0   1.0
  13200. C     medium gray    any   0.5   0.0      0.5   0.5   0.5
  13201. C     red            120   0.5   1.0      1.0   0.0   0.0
  13202. C     yellow         180   0.5   1.0      1.0   1.0   0.0
  13203. C     pink           120   0.7   0.8      0.94  0.46  0.46
  13204. C
  13205. C Reference: SIGGRAPH Status Report of the Graphic Standards Planning
  13206. C Committee, Computer Graphics, Vol.13, No.3, Association for
  13207. C Computing Machinery, New York, NY, 1979. See also: J. D. Foley et al,
  13208. C ``Computer Graphics: Principles and Practice'', second edition,
  13209. C Addison-Wesley, 1990, section 13.3.5.
  13210. C
  13211. C Argument:
  13212. C  CI     (input)  : the color index to be defined, in the range 0-max.
  13213. C                    If the color index greater than the device
  13214. C                    maximum is specified, the call is ignored. Color
  13215. C                    index 0 applies to the background color.
  13216. C  CH     (input)  : hue, in range 0.0 to 360.0.
  13217. C  CL     (input)  : lightness, in range 0.0 to 1.0.
  13218. C  CS     (input)  : saturation, in range 0.0 to 1.0.
  13219. C--
  13220. C 9-May-1988 - new routine [TJP].
  13221. C-----------------------------------------------------------------------
  13222.       REAL CR, CG, CB
  13223.       CALL GRXRGB (CH,CL,CS,CR,CG,CB)
  13224.       CALL GRSCR(CI,CR,CG,CB)
  13225.       END
  13226. C*PGSHS -- set hatching style
  13227. C%void cpgshs(float angle, float sepn, float phase);
  13228. C+
  13229.       SUBROUTINE PGSHS (ANGLE, SEPN, PHASE)
  13230.       REAL ANGLE, SEPN, PHASE
  13231. C
  13232. C Set the style to be used for hatching (fill area with fill-style 3).
  13233. C The default style is ANGLE=45.0, SEPN=1.0, PHASE=0.0.
  13234. C
  13235. C Arguments:
  13236. C  ANGLE  (input)  : the angle the hatch lines make with the
  13237. C                    horizontal, in degrees, increasing 
  13238. C                    counterclockwise (this is an angle on the
  13239. C                    view surface, not in world-coordinate space).
  13240. C  SEPN   (input)  : the spacing of the hatch lines. The unit spacing
  13241. C                    is 1 percent of the smaller of the height or
  13242. C                    width of the view surface. This should not be
  13243. C                    zero.
  13244. C  PHASE  (input)  : a real number between 0 and 1; the hatch lines
  13245. C                    are displaced by this fraction of SEPN from a
  13246. C                    fixed reference.  Adjacent regions hatched with the
  13247. C                    same PHASE have contiguous hatch lines. To hatch
  13248. C                    a region with alternating lines of two colors,
  13249. C                    fill the area twice, with PHASE=0.0 for one color
  13250. C                    and PHASE=0.5 for the other color.
  13251. C--
  13252. C 26-Feb-1995 - new routine [TJP].
  13253. C 12-Feb-1996 - check for zero spacing [TJP].
  13254. C-----------------------------------------------------------------------
  13255.       INCLUDE 'f77.PGPLOT/IN'
  13256.       LOGICAL PGNOTO
  13257. C
  13258.       IF (PGNOTO('PGSHS')) RETURN
  13259.       PGHSA(PGID) = ANGLE
  13260.       IF (SEPN.EQ.0.0) THEN
  13261.          CALL GRWARN('PGSHS: zero hatch line spacing requested')
  13262.          PGHSS(PGID) = 1.0
  13263.       ELSE
  13264.          PGHSS(PGID) = SEPN
  13265.       END IF
  13266.       IF (PHASE.LT.0.0 .OR. PHASE.GT.1.0) THEN
  13267.          CALL GRWARN('PGSHS: hatching phase must be in (0.0,1.0)')
  13268.       END IF
  13269.       PGHSP(PGID) = PHASE
  13270. C
  13271.       END
  13272. C*PGSITF -- set image transfer function
  13273. C%void cpgsitf(int itf);
  13274. C+
  13275.       SUBROUTINE PGSITF (ITF)
  13276.       INTEGER  ITF
  13277. C
  13278. C Set the Image Transfer Function for subsequent images drawn by
  13279. C PGIMAG, PGGRAY, or PGWEDG. The Image Transfer Function is used
  13280. C to map array values into the available range of color indices
  13281. C specified with routine PGSCIR or (for PGGRAY on some devices)
  13282. C into dot density.
  13283. C
  13284. C Argument:
  13285. C  ITF    (input)  : type of transfer function:
  13286. C                      ITF = 0 : linear
  13287. C                      ITF = 1 : logarithmic
  13288. C                      ITF = 2 : square-root
  13289. C--
  13290. C 15-Sep-1994 - new routine [TJP].
  13291. C-----------------------------------------------------------------------
  13292.       INCLUDE 'f77.PGPLOT/IN'
  13293.       LOGICAL PGNOTO
  13294. C
  13295.       IF (PGNOTO('PGSITF')) RETURN
  13296.       IF (ITF.LT.0 .OR. ITF.GT.2) THEN
  13297.           PGITF(PGID) = 0
  13298.           CALL GRWARN('PGSITF: argument must be 0, 1, or 2')
  13299.       ELSE
  13300.           PGITF(PGID) = ITF
  13301.       END IF
  13302.       END
  13303. C
  13304.       SUBROUTINE PGSIZE (WIDTH, HEIGHT, SHIFTX, SHIFTY, DUMMY)
  13305. C
  13306. C PGPLOT (obsolete routine; use PGVSIZ in preference): Change the
  13307. C size and position of the viewport.
  13308. C
  13309. C Arguments:
  13310. C
  13311. C WIDTH (input, real) : width of viewport in inches.
  13312. C HEIGHT (input, real) : height of viewport in inches.
  13313. C SHIFTX (input, real) : horizontal offset of bottom left corner
  13314. C       from blc of page or panel, in inches.
  13315. C SHIFTY (input, real) : vertical offset of bottom left corner
  13316. C       from blc of page or panel, in inches.
  13317. C DUMMY (input, real) : reserved for future use (must be 0.0).
  13318. C--
  13319. C 13-Dec-1990  Make errors non-fatal [TJP].
  13320. C-----------------------------------------------------------------------
  13321.       REAL     WIDTH,HEIGHT,SHIFTX,SHIFTY,DUMMY
  13322. C
  13323.       IF (WIDTH.LE.0.0 .OR. HEIGHT.LE.0.0 .OR. DUMMY.NE.0.0) THEN
  13324.           CALL GRWARN('PGSIZE ignored: invalid arguments')
  13325.           RETURN
  13326.       END IF
  13327. C
  13328.       CALL PGVSIZ(SHIFTX, SHIFTX+WIDTH, SHIFTY, SHIFTY+HEIGHT)
  13329.       END
  13330. C*PGSLCT -- select an open graphics device
  13331. C%void cpgslct(int id);
  13332. C+
  13333.       SUBROUTINE PGSLCT(ID)
  13334.       INTEGER ID
  13335. C
  13336. C Select one of the open graphics devices and direct subsequent
  13337. C plotting to it. The argument is the device identifier returned by
  13338. C PGOPEN when the device was opened. If the supplied argument is not a
  13339. C valid identifier of on open graphics device, a warning message is
  13340. C issued and the current selection is unchanged.
  13341. C
  13342. C [This routine was added to PGPLOT in Version 5.1.0.]
  13343. C
  13344. C Arguments:
  13345. C
  13346. C ID (input, integer): identifier of the device to be selected.
  13347. C--
  13348. C 22-Dec-1995 - new routine [TJP].
  13349. C-----------------------------------------------------------------------
  13350.       INCLUDE 'f77.PGPLOT/IN'
  13351. C
  13352.       IF (ID.LT.1 .OR. ID.GT.PGMAXD) THEN
  13353.          CALL GRWARN('PGSLCT: invalid argument')
  13354.       ELSE IF (PGDEVS(ID).NE.1) THEN
  13355.          CALL GRWARN('PGSLCT: requested device is not open')
  13356.       ELSE
  13357. C        -- Select the new device
  13358.          PGID = ID
  13359.          CALL GRSLCT(PGID)
  13360.       END IF
  13361. C
  13362.       END
  13363. C*PGSLS -- set line style
  13364. C%void cpgsls(int ls);
  13365. C+
  13366.       SUBROUTINE PGSLS (LS)
  13367.       INTEGER  LS
  13368. C
  13369. C Set the line style attribute for subsequent plotting. This
  13370. C attribute affects line primitives only; it does not affect graph
  13371. C markers, text, or area fill.
  13372. C Five different line styles are available, with the following codes:
  13373. C 1 (full line), 2 (dashed), 3 (dot-dash-dot-dash), 4 (dotted),
  13374. C 5 (dash-dot-dot-dot). The default is 1 (normal full line).
  13375. C
  13376. C Argument:
  13377. C  LS     (input)  : the line-style code for subsequent plotting
  13378. C                    (in range 1-5).
  13379. C--
  13380. C  8-Aug-1985 - new routine, equivalent to GRSLS [TJP].
  13381. C  3-Jun-1984 - add GMFILE device [TJP].
  13382. C-----------------------------------------------------------------------
  13383.       LOGICAL PGNOTO
  13384. C
  13385.       IF (PGNOTO('PGSLS')) RETURN
  13386.       CALL GRSLS(LS)
  13387.       END
  13388. C*PGSLW -- set line width
  13389. C%void cpgslw(int lw);
  13390. C+
  13391.       SUBROUTINE PGSLW (LW)
  13392.       INTEGER  LW
  13393. C
  13394. C Set the line-width attribute. This attribute affects lines, graph
  13395. C markers, and text. The line width is specified in units of 1/200 
  13396. C (0.005) inch (about 0.13 mm) and must be an integer in the range
  13397. C 1-201. On some devices, thick lines are generated by tracing each
  13398. C line with multiple strokes offset in the direction perpendicular to
  13399. C the line.
  13400. C
  13401. C Argument:
  13402. C  LW     (input)  : width of line, in units of 0.005 inch (0.13 mm)
  13403. C                    in range 1-201.
  13404. C--
  13405. C  8-Aug-1985 - new routine, equivalent to GRSLW [TJP].
  13406. C  1-Feb-1995 - change comment [TJP].
  13407. C-----------------------------------------------------------------------
  13408.       LOGICAL PGNOTO
  13409. C
  13410.       IF (PGNOTO('PGSLW')) RETURN
  13411.       CALL GRSLW(LW)
  13412.       END
  13413. C*PGSTBG -- set text background color index
  13414. C%void cpgstbg(int tbci);
  13415. C+
  13416.       SUBROUTINE PGSTBG (TBCI)
  13417.       INTEGER  TBCI
  13418. C
  13419. C Set the Text Background Color Index for subsequent text. By default
  13420. C text does not obscure underlying graphics. If the text background
  13421. C color index is positive, however, text is opaque: the bounding box
  13422. C of the text is filled with the color specified by PGSTBG before
  13423. C drawing the text characters in the current color index set by PGSCI.
  13424. C Use color index 0 to erase underlying graphics before drawing text.
  13425. C
  13426. C Argument:
  13427. C  TBCI   (input)  : the color index to be used for the background
  13428. C                    for subsequent text plotting:
  13429. C                      TBCI < 0  => transparent (default)
  13430. C                      TBCI >= 0 => text will be drawn on an opaque
  13431. C                    background with color index TBCI.
  13432. C--
  13433. C 16-Oct-1993 - new routine [TJP].
  13434. C-----------------------------------------------------------------------
  13435.       INCLUDE 'f77.PGPLOT/IN'
  13436.       LOGICAL PGNOTO
  13437. C
  13438.       IF (PGNOTO('PGSTBG')) RETURN
  13439.       IF (TBCI.LT.0) THEN
  13440.           PGTBCI(PGID) = -1
  13441.       ELSE
  13442.           PGTBCI(PGID) = TBCI
  13443.       END IF
  13444.       END
  13445. C*PGSUBP -- subdivide view surface into panels
  13446. C%void cpgsubp(int nxsub, int nysub);
  13447. C+
  13448.       SUBROUTINE PGSUBP (NXSUB, NYSUB)
  13449.       INTEGER NXSUB, NYSUB
  13450. C
  13451. C PGPLOT divides the physical surface of the plotting device (screen,
  13452. C window, or sheet of paper) into NXSUB x NYSUB `panels'. When the 
  13453. C view surface is sub-divided in this way, PGPAGE moves to the next
  13454. C panel, not the next physical page. The initial subdivision of the
  13455. C view surface is set in the call to PGBEG. When PGSUBP is called,
  13456. C it forces the next call to PGPAGE to start a new physical page,
  13457. C subdivided in the manner indicated. No plotting should be done
  13458. C between a call of PGSUBP and a call of PGPAGE (or PGENV, which calls
  13459. C PGPAGE).
  13460. C
  13461. C If NXSUB > 0, PGPLOT uses the panels in row order; if <0, 
  13462. C PGPLOT uses them in column order, e.g.,
  13463. C      
  13464. C  NXSUB=3, NYSUB=2            NXSUB=-3, NYSUB=2   
  13465. C                                                
  13466. C +-----+-----+-----+         +-----+-----+-----+
  13467. C |  1  |  2  |  3  |         |  1  |  3  |  5  |
  13468. C +-----+-----+-----+         +-----+-----+-----+
  13469. C |  4  |  5  |  6  |         |  2  |  4  |  6  |
  13470. C +-----+-----+-----+         +-----+-----+-----+
  13471. C
  13472. C PGPLOT advances from one panels to the next when PGPAGE is called,
  13473. C clearing the screen or starting a new page when the last panel has
  13474. C been used. It is also possible to jump from one panel to another
  13475. C in random order by calling PGPANL.
  13476. C 
  13477. C Arguments:
  13478. C  NXSUB  (input)  : the number of subdivisions of the view surface in
  13479. C                    X (>0 or <0).
  13480. C  NYSUB  (input)  : the number of subdivisions of the view surface in
  13481. C                    Y (>0).
  13482. C--
  13483. C 15-Nov-1993 [TJP] - new routine.
  13484. C 19-Feb-1994 [TJP] - rescale viewport when panel size changes.
  13485. C 23-Sep-1996 [TJP] - correct bug in assignment of PGROWS.
  13486. C-----------------------------------------------------------------------
  13487.       INCLUDE  'f77.PGPLOT/IN'
  13488.       REAL     CH, XFSZ, YFSZ
  13489.       LOGICAL  PGNOTO
  13490.       REAL     XVP1, XVP2, YVP1, YVP2
  13491.  
  13492. C
  13493.       IF (PGNOTO('PGSUBP')) RETURN
  13494. C
  13495. C Find current character size and viewport (NDC).
  13496. C
  13497.       CALL PGQCH(CH)
  13498.       CALL PGQVP(0, XVP1, XVP2, YVP1, YVP2)
  13499. C
  13500. C Set the subdivisions.
  13501. C
  13502.       XFSZ = PGNX(PGID)*PGXSZ(PGID)
  13503.       YFSZ = PGNY(PGID)*PGYSZ(PGID)
  13504.       PGROWS(PGID) = (NXSUB.GE.0)
  13505.       PGNX(PGID) = MAX(ABS(NXSUB),1)
  13506.       PGNY(PGID) = MAX(ABS(NYSUB),1)
  13507.       PGXSZ(PGID) = XFSZ/PGNX(PGID)
  13508.       PGYSZ(PGID) = YFSZ/PGNY(PGID)
  13509. C
  13510. C The current panel is the last on the physical page, to force
  13511. C a new physical page at next PGPAGE.
  13512. C
  13513.       PGNXC(PGID) = PGNX(PGID)
  13514.       PGNYC(PGID) = PGNY(PGID)
  13515. C
  13516. C Rescale the character size and viewport to the new panel size.
  13517. C
  13518.       CALL PGSCH(CH)
  13519.       CALL PGSVP(XVP1, XVP2, YVP1, YVP2)
  13520. C
  13521.       END
  13522. C*PGSVP -- set viewport (normalized device coordinates)
  13523. C%void cpgsvp(float xleft, float xright, float ybot, float ytop);
  13524. C+
  13525.       SUBROUTINE PGSVP (XLEFT, XRIGHT, YBOT, YTOP)
  13526.       REAL XLEFT, XRIGHT, YBOT, YTOP
  13527. C
  13528. C Change the size and position of the viewport, specifying
  13529. C the viewport in normalized device coordinates.  Normalized
  13530. C device coordinates run from 0 to 1 in each dimension. The
  13531. C viewport is the rectangle on the view surface "through"
  13532. C which one views the graph.  All the PG routines which plot lines
  13533. C etc. plot them within the viewport, and lines are truncated at
  13534. C the edge of the viewport (except for axes, labels etc drawn with
  13535. C PGBOX or PGLAB).  The region of world space (the coordinate
  13536. C space of the graph) which is visible through the viewport is
  13537. C specified by a call to PGSWIN.  It is legal to request a
  13538. C viewport larger than the view surface; only the part which
  13539. C appears on the view surface will be plotted.
  13540. C
  13541. C Arguments:
  13542. C  XLEFT  (input)  : x-coordinate of left hand edge of viewport, in NDC.
  13543. C  XRIGHT (input)  : x-coordinate of right hand edge of viewport,
  13544. C                    in NDC.
  13545. C  YBOT   (input)  : y-coordinate of bottom edge of viewport, in NDC.
  13546. C  YTOP   (input)  : y-coordinate of top  edge of viewport, in NDC.
  13547. C--
  13548. C 13-Dec-1990  Make errors non-fatal [TJP].
  13549. C-----------------------------------------------------------------------
  13550.       INCLUDE  'f77.PGPLOT/IN'
  13551.       LOGICAL  PGNOTO
  13552.       REAL     XS, YS
  13553. C
  13554.       IF (PGNOTO('PGSVP'))  RETURN
  13555.       IF (XLEFT.GE.XRIGHT .OR. YBOT.GE.YTOP) THEN
  13556.           CALL GRWARN('PGSVP ignored: invalid arguments')
  13557.           RETURN
  13558.       END IF
  13559. C
  13560.       XS = PGXSZ(PGID)/PGXPIN(PGID)
  13561.       YS = PGYSZ(PGID)/PGYPIN(PGID)
  13562.       CALL PGVSIZ(XLEFT*XS, XRIGHT*XS, YBOT*YS, YTOP*YS)
  13563.       END
  13564. C*PGSWIN -- set window
  13565. C%void cpgswin(float x1, float x2, float y1, float y2);
  13566. C+
  13567.       SUBROUTINE PGSWIN (X1, X2, Y1, Y2)
  13568.       REAL X1, X2, Y1, Y2
  13569. C
  13570. C Change the window in world coordinate space that is to be mapped on
  13571. C to the viewport.  Usually PGSWIN is called automatically by PGENV,
  13572. C but it may be called directly by the user.
  13573. C
  13574. C Arguments:
  13575. C  X1     (input)  : the x-coordinate of the bottom left corner
  13576. C                    of the viewport.
  13577. C  X2     (input)  : the x-coordinate of the top right corner
  13578. C                    of the viewport (note X2 may be less than X1).
  13579. C  Y1     (input)  : the y-coordinate of the bottom left corner
  13580. C                    of the viewport.
  13581. C  Y2     (input)  : the y-coordinate of the top right corner
  13582. C                    of the viewport (note Y2 may be less than Y1).
  13583. C--
  13584. C 15-Nov-95: check arguments to prevent divide-by-zero [TJP].
  13585. C-----------------------------------------------------------------------
  13586.       INCLUDE 'f77.PGPLOT/IN'
  13587.       LOGICAL PGNOTO
  13588. C
  13589.       IF (PGNOTO('PGSWIN')) RETURN
  13590. C
  13591. C If invalid arguments are specified, issue warning and leave window
  13592. C unchanged.
  13593. C
  13594.       IF (X1.EQ.X2) THEN
  13595.          CALL GRWARN('invalid x limits in PGSWIN: X1 = X2.')
  13596.       ELSE IF (Y1.EQ.Y2) THEN
  13597.          CALL GRWARN('invalid y limits in PGSWIN: Y1 = Y2.')
  13598.       ELSE
  13599.          PGXBLC(PGID) = X1
  13600.          PGXTRC(PGID) = X2
  13601.          PGYBLC(PGID) = Y1
  13602.          PGYTRC(PGID) = Y2
  13603.          CALL PGVW
  13604.       END IF
  13605.       END
  13606. C*PGTBOX -- draw frame and write (DD) HH MM SS.S labelling
  13607. C%void cpgtbox(const char *xopt, float xtick, int nxsub, \
  13608. C% const char *yopt, float ytick, int nysub);
  13609. C+
  13610.       SUBROUTINE PGTBOX (XOPT, XTICK, NXSUB, YOPT, YTICK, NYSUB)
  13611. C
  13612.       REAL XTICK, YTICK
  13613.       INTEGER NXSUB, NYSUB
  13614.       CHARACTER XOPT*(*), YOPT*(*)
  13615. C
  13616. C Draw a box and optionally label one or both axes with (DD) HH MM SS 
  13617. C style numeric labels (useful for time or RA - DEC plots).   If this 
  13618. C style of labelling is desired, then PGSWIN should have been called
  13619. C previously with the extrema in SECONDS of time.
  13620. C
  13621. C In the seconds field, you can have at most 3 places after the decimal
  13622. C point, so that 1 ms is the smallest time interval you can time label.
  13623. C
  13624. C Large numbers are coped with by fields of 6 characters long.  Thus 
  13625. C you could have times with days or hours as big as 999999.  However, 
  13626. C in practice, you might have trouble with labels overwriting  themselves
  13627. C with such large numbers unless you a) use a small time INTERVAL, 
  13628. C b) use a small character size or c) choose your own sparse ticks in 
  13629. C the call to PGTBOX.  
  13630. C
  13631. C PGTBOX will attempt, when choosing its own ticks, not to overwrite
  13632. C the labels, but this algorithm is not very bright and may fail.
  13633. C
  13634. C Note that small intervals but large absolute times such as
  13635. C TMIN = 200000.0 s and TMAX=200000.1 s will cause the algorithm
  13636. C to fail.  This is inherent in PGPLOT's use of single precision
  13637. C and cannot be avoided.  In such cases, you should use relative
  13638. C times if possible.
  13639. C
  13640. C PGTBOX's labelling philosophy is that the left-most or bottom tick of
  13641. C the axis contains a full label.  Thereafter, only changing fields are
  13642. C labelled.  Negative fields are given a '-' label, positive fields
  13643. C have none.   Axes that have the DD (or HH if the day field is not
  13644. C used) field on each major tick carry the sign on each field.  If the
  13645. C axis crosses zero, the zero tick will carry a full label and sign.
  13646. C
  13647. C This labelling style can cause a little confusion with some special
  13648. C cases, but as long as you know its philosophy, the truth can be divined.
  13649. C Consider an axis with TMIN=20s, TMAX=-20s.   The labels will look like
  13650. C
  13651. C        +----------+----------+----------+----------+
  13652. C     0h0m20s      10s      -0h0m0s      10s        20s
  13653. C
  13654. C Knowing that the left field always has a full label and that
  13655. C positive fields are unsigned, informs that time is decreasing
  13656. C from left to right, not vice versa.   This can become very 
  13657. C unclear if you have used the 'F' option, but that is your problem !
  13658. C
  13659. C Exceptions to this labelling philosophy are when the finest time
  13660. C increment being displayed is hours (with option 'Y') or days.  
  13661. C Then all fields carry a label.  For example,
  13662. C
  13663. C        +----------+----------+----------+----------+
  13664. C      -10h        -8h        -6h        -4h        -2h
  13665. C
  13666. C
  13667. C PGTBOX can be used in place of PGBOX; it calls PGBOX and only invokes 
  13668. C time labelling if requested. Other options are passed intact to PGBOX.
  13669. C
  13670. C Inputs:
  13671. C  XOPT   :  X-options for PGTBOX.  Same as for PGBOX plus 
  13672. C
  13673. C             'Z' for (DD) HH MM SS.S time labelling
  13674. C             'Y' means don't include the day field so that labels
  13675. C                 are HH MM SS.S rather than DD HH MM SS.S   The hours
  13676. C                 will accumulate beyond 24 if necessary in this case.
  13677. C             'X' label the HH field as modulo 24.  Thus, a label
  13678. C                 such as 25h 10m would come out as 1h 10m
  13679. C             'H' means superscript numbers with d, h, m, & s  symbols
  13680. C             'D' means superscript numbers with    o, ', & '' symbols 
  13681. C             'F' causes the first label (left- or bottom-most) to
  13682. C                 be omitted. Useful for sub-panels that abut each other.
  13683. C                 Care is needed because first label carries sign as well.
  13684. C             'O' means omit leading zeros in numbers < 10
  13685. C                 E.g.  3h 3m 1.2s rather than 03h 03m 01.2s  Useful
  13686. C                 to help save space on X-axes. The day field does not 
  13687. C                 use this facility.
  13688. C
  13689. C  YOPT   :  Y-options for PGTBOX.  See above.
  13690. C  XTICK  :  X-axis major tick increment.  0.0 for default. 
  13691. C  YTICK  :  Y-axis major tick increment.  0.0 for default. 
  13692. C            If the 'Z' option is used then XTICK and/or YTICK must
  13693. C            be in seconds.
  13694. C  NXSUB  :  Number of intervals for minor ticks on X-axis. 0 for default
  13695. C  NYSUB  :  Number of intervals for minor ticks on Y-axis. 0 for default
  13696. C
  13697. C  The regular XOPT and YOPT axis options for PGBOX are
  13698. C
  13699. C  A : draw Axis (X axis is horizontal line Y=0, Y axis is vertical
  13700. C      line X=0).
  13701. C  B : draw bottom (X) or left (Y) edge of frame.
  13702. C  C : draw top (X) or right (Y) edge of frame.
  13703. C  G : draw Grid of vertical (X) or horizontal (Y) lines.
  13704. C  I : Invert the tick marks; ie draw them outside the viewport
  13705. C      instead of inside.
  13706. C  L : label axis Logarithmically (see below).
  13707. C  N : write Numeric labels in the conventional location below the
  13708. C      viewport (X) or to the left of the viewport (Y).
  13709. C  P : extend ("Project") major tick marks outside the box (ignored if
  13710. C      option I is specified).
  13711. C  M : write numeric labels in the unconventional location above the
  13712. C      viewport (X) or to the right of the viewport (Y).
  13713. C  T : draw major Tick marks at the major coordinate interval.
  13714. C  S : draw minor tick marks (Subticks).
  13715. C  V : orient numeric labels Vertically. This is only applicable to Y.
  13716. C      The default is to write Y-labels parallel to the axis.
  13717. C  1 : force decimal labelling, instead of automatic choice (see PGNUMB).
  13718. C  2 : force exponential labelling, instead of automatic.
  13719. C
  13720. C      The default is to write Y-labels parallel to the axis
  13721. C  
  13722. C
  13723. C        ******************        EXCEPTIONS       *******************
  13724. C
  13725. C        Note that 
  13726. C          1) PGBOX option 'L' (log labels) is ignored with option 'Z'
  13727. C          2) The 'O' option will be ignored for the 'V' option as it 
  13728. C             makes it impossible to align the labels nicely
  13729. C          3) Option 'Y' is forced with option 'D'
  13730. C
  13731. C        ***************************************************************
  13732. C
  13733. C
  13734. C--
  13735. C 05-Sep-1988 - new routine (Neil Killeen)
  13736. C 20-Apr-1991 - add support for new DD (day) field and implement
  13737. C               labelling on any axis (bottom,top,left,right) [nebk]
  13738. C 10-Jun-1993 - add option 'O' for leading zeros, correctly deal with 
  13739. C               user ticks, fully support 'V' and 'NM' options, modify
  13740. C               slightly meaning of 'F' option [nebk]
  13741. C 16-Jan-1995 - add option 'X' [nebk]
  13742. C 16-Aug-1996 - Bring axis labelling displacements more in line with 
  13743. C               those of pgbox.f [nebk]
  13744. C-----------------------------------------------------------------------
  13745.       REAL XTICKD, YTICKD, XMIN, XMAX, YMIN, YMAX
  13746.       INTEGER IPT, TSCALX, TSCALY, NXSUBD, NYSUBD
  13747.       CHARACTER XXOPT*15, YYOPT*15, SUPTYP*4
  13748.       LOGICAL XTIME, YTIME, FIRST, DODAYX, DODAYY, DO2, DOPARA, MOD24
  13749. C------------------------------------------------------------------------
  13750. C
  13751. C  Copy inputs
  13752. C
  13753.       XTICKD = XTICK
  13754.       YTICKD = YTICK
  13755.       NXSUBD = NXSUB
  13756.       NYSUBD = NYSUB
  13757. C
  13758. C  Get window in world coordinates
  13759. C 
  13760.       CALL PGQWIN (XMIN, XMAX, YMIN, YMAX)
  13761. C
  13762. C  X-axis first
  13763. C
  13764.       CALL GRTOUP (XXOPT, XOPT)
  13765.       XTIME = .FALSE.
  13766.       IF (INDEX(XXOPT,'Z').NE.0) THEN
  13767. C
  13768. C  Work out units for labelling and find the tick increments.
  13769. C
  13770.         IF (ABS(XMAX-XMIN).LT.0.001) THEN
  13771.           CALL GRWARN ('PGTBOX: X-axis time interval too small '//
  13772.      *                 '(< 1 ms) for time labels')
  13773.         ELSE
  13774.           XTIME = .TRUE.
  13775.           DODAYX = .TRUE.
  13776.           IF (INDEX(XXOPT,'Y').NE.0 .OR. INDEX(XXOPT,'D').NE.0) 
  13777.      *        DODAYX = .FALSE.
  13778. C
  13779.           DOPARA = .TRUE.
  13780.           CALL PGTBX1 ('X', DODAYX, DOPARA, XMIN, XMAX, XTICKD, 
  13781.      *                 NXSUBD, TSCALX)
  13782.         END IF
  13783.       END IF
  13784. C
  13785. C  Same again for Y-axis
  13786. C
  13787.       CALL GRTOUP (YYOPT, YOPT)
  13788.       YTIME = .FALSE.
  13789.       IF (INDEX(YYOPT,'Z').NE.0) THEN
  13790.         IF (ABS(YMAX-YMIN).LT.0.001) THEN
  13791.           CALL GRWARN ('PGTBOX: Y-axis time interval too small '//
  13792.      *                 '(< 1ms) for time labels')
  13793.         ELSE
  13794.           YTIME = .TRUE.
  13795.           DODAYY = .TRUE.
  13796.           IF (INDEX(YYOPT,'Y').NE.0 .OR. INDEX(YYOPT,'D').NE.0)
  13797.      *        DODAYY = .FALSE.
  13798. C
  13799.           DOPARA = .TRUE.
  13800.           IF (INDEX(YYOPT,'V').NE.0) DOPARA = .FALSE.
  13801. C
  13802.           CALL PGTBX1 ('Y', DODAYY, DOPARA, YMIN, YMAX, YTICKD, 
  13803.      *                 NYSUBD, TSCALY)
  13804.         END IF
  13805.       END IF
  13806. C
  13807. C  Parse options list.  For call to PGBOX when doing time labelling, we 
  13808. C  don't want L (log), N or M (write numeric labels). 
  13809. C
  13810.       IF (XTIME) THEN
  13811.         IPT = INDEX(XXOPT,'L')
  13812.         IF (IPT.NE.0) XXOPT(IPT:IPT) = ' '
  13813.         IPT = INDEX(XXOPT,'N')
  13814.         IF (IPT.NE.0) XXOPT(IPT:IPT) = ' '
  13815.         IPT = INDEX(XXOPT,'M')
  13816.         IF (IPT.NE.0) XXOPT(IPT:IPT) = ' '
  13817.       END IF
  13818. C
  13819.       IF (YTIME) THEN
  13820.         IPT = INDEX(YYOPT,'L')
  13821.         IF (IPT.NE.0) YYOPT(IPT:IPT) = ' '
  13822.         IPT = INDEX(YYOPT,'N')
  13823.         IF (IPT.NE.0) YYOPT(IPT:IPT) = ' '
  13824.         IPT = INDEX(YYOPT,'M')
  13825.         IF (IPT.NE.0) YYOPT(IPT:IPT) = ' '
  13826.       END IF
  13827. C
  13828. C  Draw box and ticks
  13829. C
  13830.       CALL PGBOX (XXOPT, XTICKD, NXSUBD, YYOPT, YTICKD, NYSUBD)
  13831. C
  13832. C  Add (DD) HH MM SS labels if desired.  Go back to the original user
  13833. C  specified options list.
  13834. C
  13835.       XXOPT = ' '
  13836.       CALL GRTOUP (XXOPT, XOPT)
  13837.       IF (XTIME .AND. (INDEX(XXOPT,'N').NE.0 .OR.
  13838.      *                 INDEX(XXOPT,'M').NE.0)) THEN
  13839.         FIRST = .TRUE.
  13840.         IF (INDEX(XXOPT,'F').NE.0) FIRST = .FALSE.
  13841. C
  13842.         SUPTYP = 'NONE'
  13843.         IF (INDEX(XXOPT,'D').NE.0) SUPTYP = ' DMS'
  13844.         IF (INDEX(XXOPT,'H').NE.0) SUPTYP = 'DHMS'
  13845. C
  13846.         DO2 = .TRUE.
  13847.         IF (INDEX(XXOPT,'O').NE.0) DO2 = .FALSE.
  13848. C
  13849.         DOPARA = .TRUE.
  13850. C
  13851.         MOD24 = .FALSE.
  13852.         IF (INDEX(XXOPT,'X').NE.0) MOD24 = .TRUE.
  13853. C
  13854.         IF (INDEX(XXOPT,'N').NE.0)
  13855.      *    CALL PGTBX4 (DODAYX, SUPTYP, 'X', .TRUE., FIRST, 
  13856.      *      XMIN, XMAX, TSCALX, XTICKD, DO2, DOPARA, MOD24)
  13857. C
  13858.         IF (INDEX(XXOPT,'M').NE.0)
  13859.      *    CALL PGTBX4 (DODAYX, SUPTYP, 'X', .FALSE., FIRST, 
  13860.      *       XMIN, XMAX, TSCALX, XTICKD, DO2, DOPARA, MOD24)
  13861.       END IF
  13862. C
  13863.       YYOPT = ' '
  13864.       CALL GRTOUP (YYOPT, YOPT)
  13865.       IF (YTIME .AND. (INDEX(YYOPT,'N').NE.0 .OR.
  13866.      *                 INDEX(YYOPT,'M').NE.0)) THEN
  13867.         FIRST = .TRUE.
  13868.         IF (INDEX(YYOPT,'F').NE.0) FIRST = .FALSE.
  13869. C
  13870.         SUPTYP = 'NONE'
  13871.         IF (INDEX(YYOPT,'D').NE.0) SUPTYP = ' DMS'
  13872.         IF (INDEX(YYOPT,'H').NE.0) SUPTYP = 'DHMS'
  13873. C
  13874.         DOPARA = .TRUE.
  13875.         IF (INDEX(YYOPT,'V').NE.0) DOPARA = .FALSE.
  13876. C
  13877.         DO2 = .TRUE.
  13878.         IF (DOPARA .AND. INDEX(YYOPT,'O').NE.0) DO2 = .FALSE.
  13879. C
  13880.         MOD24 = .FALSE.
  13881.         IF (INDEX(YYOPT,'X').NE.0) MOD24 = .TRUE.
  13882. C
  13883.         IF (INDEX(YYOPT,'N').NE.0)
  13884.      *    CALL PGTBX4 (DODAYY, SUPTYP, 'Y', .TRUE., FIRST, 
  13885.      *       YMIN, YMAX, TSCALY, YTICKD, DO2, DOPARA, MOD24)
  13886. C
  13887.         IF (INDEX(YYOPT,'M').NE.0)
  13888.      *    CALL PGTBX4 (DODAYY, SUPTYP, 'Y', .FALSE., FIRST, 
  13889.      *       YMIN, YMAX, TSCALY, YTICKD, DO2, DOPARA, MOD24)
  13890. C
  13891.       END IF
  13892. C
  13893.       RETURN
  13894.       END
  13895. C PGTBX1 -- support routine for PGTBOX
  13896. C
  13897.       SUBROUTINE PGTBX1 (AXIS, DODAY, DOPARA, TMIN, TMAX, TICK, 
  13898.      *                   NSUB, TSCALE)
  13899. C
  13900.       REAL TMIN, TMAX, TICK
  13901.       INTEGER NSUB, TSCALE
  13902.       LOGICAL DODAY, DOPARA
  13903.       CHARACTER AXIS*1
  13904. C
  13905. C Work out what the finest units the time labels will be in and
  13906. C return the tick increments if the user does not set them.
  13907. C
  13908. C This is a support routine for PGTBOX and should not 
  13909. C be called by the user.
  13910. C
  13911. C Input:
  13912. C  AXIS   :  'X' or 'Y' for use in determining if labels overwrite
  13913. C  TMIN   :  Start time in seconds 
  13914. C  TMAX   :  End   time in seconds
  13915. C  DOPARA :  True if label to be parallel to axis, else perpendicular
  13916. C Input/output:
  13917. C  DODAY  :  Write labels as DD HH MM SS.S else HH MM SS.S with
  13918. C            hours ranging above 24.  Useful for declination labels
  13919. C  TICK   :  Major tick interval in seconds.  If 0.0 on input, will 
  13920. C            be set here.
  13921. C  NSUB   :  Number of minor ticks between major ticks. If 0 on input
  13922. C            will be set here.
  13923. C Outputs:
  13924. C  TSCALE :  Determines finest unit of labelling 
  13925. C            (1 => ss, 60 => mm, 3600 => hh, 3600*24 => dd)
  13926. C
  13927. C 05-Sep-1988 - new routine (Neil Killeen)
  13928. C 08-Apr-1991 - correctly work out HH MM SS when the time > 60 h [nebk]
  13929. C 20-Apr-1991 - revise to add support for new DD (day) field and
  13930. C               do lots of work on tick algorithm [nebk]
  13931. C 10-Jun-1993 - deal with user given ticks & rename from PGTIME [nebk/jm]
  13932. C-----------------------------------------------------------------------
  13933.       INTEGER NLIST1, NLIST2, NLIST3, NLIST4, NTICMX
  13934.       PARAMETER (NLIST1 = 19, NLIST2 = 10, NLIST3 = 6, NLIST4 = 8,
  13935.      *           NTICMX = 8)
  13936. C
  13937.       REAL TICKS1(NLIST1), TICKS2(NLIST2), TICKS3(NLIST3), 
  13938.      *TICKS4(NLIST4), TOCK, TOCK2, TINT, TINTS, TMINS, TMAXS
  13939.       INTEGER NSUBS1(NLIST1), NSUBS2(NLIST2), NSUBS3(NLIST3), 
  13940.      *NSUBS4(NLIST4), NPL, NTICK, ITICK, STRLEN
  13941.       CHARACTER STR*15
  13942. C
  13943.       SAVE TICKS1, TICKS2, TICKS3, TICKS4
  13944.       SAVE NSUBS1, NSUBS2, NSUBS3, NSUBS4
  13945. C
  13946.       DATA TICKS1 /0.001,  0.002,                 0.005,
  13947.      *             0.01,   0.02,                  0.05,  
  13948.      *             0.1,    0.2,                   0.5,  
  13949.      *             1.0,    2.0,   3.0,    4.0,    5.0,
  13950.      *             6.0,   10.0,  15.0,   20.0,   30.0/
  13951.       DATA NSUBS1 / 4,      4,                     2,    
  13952.      *              4,      4,                     2,    
  13953.      *              4,      4,                     2,    
  13954.      *              4,      4,     3,      4,      5,
  13955.      *              3,      2,     3,      2,      3/
  13956. C
  13957.       DATA TICKS2 /1.0,    2.0,   3.0,    4.0,    5.0,
  13958.      *             6.0,   10.0,  15.0,   20.0,   30.0/
  13959.       DATA NSUBS2 / 4,      4,     3,      4,      5,
  13960.      *              3,      2,     3,      2,      3/
  13961. C
  13962.       DATA TICKS3 /1.0,    2.0,   3.0,    4.0,    6.0,   12.0/
  13963.       DATA NSUBS3 / 4,      4,     3,      4,      3,      2/
  13964. C
  13965.       DATA TICKS4 /1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 8.0, 9.0/
  13966.       DATA NSUBS4 / 4,   4,   3,   4,   5,   3,   4,   3 /
  13967. C----------------------------------------------------------------------
  13968. C
  13969. C  Turn off DD (day) field if it has been unnecessarily asked for
  13970. C
  13971.       IF ((ABS(TMIN).LT.24.0*3600.0) .AND. (ABS(TMAX).LT.24.0*3600.0))
  13972.      *   DODAY = .FALSE.
  13973. C
  13974. C  If a tick size is provided, use it to determine TSCALE
  13975. C
  13976.       TINT = ABS(TMAX - TMIN)
  13977.       TICK = ABS(TICK)
  13978.       IF (TICK.NE.0.0) THEN
  13979.         IF (TICK.GE.TINT) THEN
  13980.           CALL GRWARN ('PGTBX1: user given tick bigger than time '
  13981.      *                 //'interval; will auto-tick')
  13982.           TICK = 0.0
  13983.         ELSE IF (TICK.LT.0.001) THEN
  13984.           CALL GRWARN ('PGTBX1: user given tick too small (< 1 ms); '
  13985.      *                 //'will auto-tick')
  13986.           TICK = 0.0
  13987.         ELSE 
  13988.           IF (MOD(TICK, 60.0) .NE. 0.0) THEN
  13989.             TSCALE = 1
  13990.           ELSE IF (MOD(TICK, 3600.0).NE.0.0) THEN
  13991.             TSCALE = 60
  13992.           ELSE IF (.NOT.DODAY) THEN
  13993.             TSCALE = 3600
  13994.           ELSE IF (MOD(TICK,(24.0*3600.0)).NE.0.0) THEN
  13995.             TSCALE = 3600
  13996.           ELSE
  13997.             TSCALE = 24 * 3600
  13998.           ENDIF
  13999. C
  14000. C  Make a simple default for the number of minor ticks and bug out
  14001. C
  14002.           IF (NSUB.EQ.0) NSUB = 2
  14003.           RETURN
  14004.         END IF
  14005.       END IF
  14006. C
  14007. C  Work out label units depending on time interval if user 
  14008. C  wants auto-ticking
  14009. C
  14010.       IF (TINT.LE.5*60) THEN
  14011.         TSCALE = 1
  14012.       ELSE IF (TINT.LE.5*3600) THEN
  14013.         TSCALE = 60
  14014.       ELSE 
  14015.         IF (.NOT.DODAY) THEN
  14016.           TSCALE = 3600
  14017.         ELSE
  14018.           IF (TINT.LE.5*24*3600) THEN
  14019.             TSCALE = 3600
  14020.           ELSE
  14021.             TSCALE = 3600*24
  14022.           END IF
  14023.         END IF
  14024.       END IF
  14025. C
  14026. CCCCC
  14027. C  Divide interval into NTICK major ticks and NSUB minor intervals
  14028. C  The tick choosing algorithm is not very robust, so watch out
  14029. C  if you fiddle anything. 
  14030. CCCCC
  14031. C
  14032.       TINTS = TINT / TSCALE
  14033.       IF (TSCALE.EQ.1) THEN
  14034. C
  14035. C  Time in seconds.  If the time interval is very small, may need to 
  14036. C  label with up to 3 decimal places.  Have less ticks to help prevent
  14037. C  label overwrite. STR is a dummy tick label to assess label 
  14038. C  overwrite potential
  14039. C
  14040.         IF (DOPARA) THEN
  14041.           IF (TINTS.LE.0.01) THEN
  14042.             NTICK = 4
  14043.             STR = '60.423'
  14044.             STRLEN = 6
  14045.           ELSE IF (TINTS.LE.0.1) THEN
  14046.             NTICK = 5
  14047.             STR = '60.42'
  14048.             STRLEN = 5
  14049.           ELSE IF (TINTS.LE.1.0) THEN
  14050.             NTICK = 6
  14051.             STR = '60.4'
  14052.             STRLEN = 4
  14053.           ELSE
  14054.             NTICK = 6
  14055.             STR = '60s'
  14056.             STRLEN = 3
  14057.           END IF
  14058.         ELSE
  14059.           NTICK = 6
  14060.           STR = ' '
  14061.           STRLEN = 1
  14062.         END IF
  14063.         TOCK = TINTS / NTICK
  14064. C
  14065. C  Select nearest tick to TOCK from list.
  14066. C
  14067.         CALL PGTBX2 (TOCK, NLIST1, TICKS1, NSUBS1, TICK, NSUB, ITICK)
  14068. C
  14069. C  Check label overwrite and/or too many ticks.
  14070. C
  14071.         CALL PGTBX3 (DODAY, 0, TSCALE, TINTS, NTICMX, NLIST1, TICKS1,
  14072.      *               NSUBS1, ITICK, AXIS, DOPARA, STR(1:STRLEN),
  14073.      *               TICK, NSUB)
  14074.       ELSE IF (TSCALE.EQ.60) THEN
  14075. C
  14076. C  Time in minutes 
  14077. C
  14078.         NTICK = 6
  14079.         TOCK = TINTS / NTICK
  14080. C
  14081. C  Select nearest tick from list
  14082. C
  14083.         CALL PGTBX2 (TOCK, NLIST2, TICKS2, NSUBS2, TICK, NSUB, ITICK)
  14084. C
  14085. C  Check label overwrite and/or too many ticks.
  14086. C
  14087.         IF (DOPARA) THEN
  14088.           STR = '42m'
  14089.           STRLEN = 3
  14090.         ELSE
  14091.           STR = ' '
  14092.           STRLEN = 1
  14093.         END IF
  14094.         CALL PGTBX3 (DODAY, 0, TSCALE, TINTS, NTICMX, NLIST2, TICKS2,
  14095.      *               NSUBS2, ITICK, AXIS, DOPARA, STR(1:STRLEN),
  14096.      *               TICK, NSUB)
  14097.       ELSE 
  14098.         IF (TSCALE.EQ.3600 .AND. DODAY) THEN
  14099. C
  14100. C  Time in hours with the day field 
  14101. C
  14102.           NTICK = 6
  14103.           TOCK = TINTS / NTICK
  14104. C
  14105. C  Select nearest tick from list
  14106. C
  14107.           CALL PGTBX2 (TOCK, NLIST3, TICKS3, NSUBS3, TICK, NSUB, ITICK)
  14108. C
  14109. C   Check label overwrite and/or too many ticks.
  14110. C
  14111.           IF (DOPARA) THEN
  14112.             STR = '42h'
  14113.             STRLEN = 3
  14114.           ELSE
  14115.             STR = ' '
  14116.             STRLEN = 1
  14117.           END IF
  14118.           CALL PGTBX3 (DODAY, 0, TSCALE, TINTS, NTICMX, NLIST3, TICKS3,
  14119.      *                 NSUBS3, ITICK, AXIS, DOPARA, STR(1:STRLEN),
  14120.      *                 TICK, NSUB)
  14121.         ELSE
  14122. C
  14123. C  Time in hours with no day field or time in days. Have less
  14124. C  ticks for big numbers or the parallel labels will overwrite.
  14125.  
  14126.           IF (DOPARA) THEN
  14127.             TMINS = ABS(TMIN) / TSCALE
  14128.             TMAXS = ABS(TMAX) / TSCALE            
  14129.             CALL PGNPL (-1, NINT(MAX(TINTS,TMINS,TMAXS)), NPL)
  14130.             IF (NPL.LE.3) THEN
  14131.               NTICK = 6
  14132.             ELSE IF (NPL.EQ.4) THEN
  14133.               NTICK = 5
  14134.             ELSE
  14135.               NTICK = 4
  14136.             END IF
  14137.             STR = '345678912'
  14138.             STR(NPL+1:) = 'd'
  14139.             STRLEN = NPL + 1
  14140.           ELSE
  14141.             STR = ' '
  14142.             STRLEN = 1
  14143.             NTICK = 6
  14144.           END IF
  14145.           TOCK = TINTS / NTICK
  14146. C
  14147. C   Select nearest tick from list; 1 choose nearest nice integer 
  14148. C   scaled by the appropriate power of 10
  14149. C
  14150.           CALL PGNPL (-1, NINT(TOCK), NPL)
  14151.           TOCK2 = TOCK / 10**(NPL-1)
  14152. C
  14153.           CALL PGTBX2 (TOCK2, NLIST4, TICKS4, NSUBS4, TICK, NSUB, ITICK)
  14154.           TICK = TICK * 10**(NPL-1)
  14155. C
  14156. C  Check label overwrite and/or too many ticks.
  14157. C
  14158.           CALL PGTBX3 (DODAY, NPL, TSCALE, TINTS, NTICMX, NLIST4, 
  14159.      *                 TICKS4, NSUBS4, ITICK, AXIS, DOPARA,
  14160.      *                 STR(1:STRLEN), TICK, NSUB)
  14161.         END IF
  14162.       END IF
  14163. C
  14164. C  Convert tick to seconds
  14165. C
  14166.       TICK = TICK * TSCALE
  14167. C
  14168.       RETURN
  14169.       END
  14170. C PGTBX2 -- support routine for PGTBOX
  14171. C
  14172.       SUBROUTINE PGTBX2 (TOCK, NTICKS, TICKS, NSUBS, TICK, NSUB, ITICK)
  14173. C
  14174.       INTEGER NTICKS, NSUBS(NTICKS), NSUB, ITICK
  14175.       REAL TOCK, TICKS(NTICKS), TICK
  14176. C
  14177. C Find the nearest tick in a list to a given value.
  14178. C
  14179. C This is a support routine for PGTBOX and should not be called
  14180. C by the user.
  14181. C
  14182. C Input:
  14183. C  TOCK   :  Try to find the nearest tick in the list to TOCK
  14184. C  NTICKS :  Number of ticks in list
  14185. C  TICKS  :  List of ticks
  14186. C  NSUBS  :  List of number of minor ticks between ticks to go with TICKS
  14187. C Output:
  14188. C  TICK   :  The selected tick
  14189. C  ITICK  :  The index of the selected tick from the list TICKS
  14190. C Input/output
  14191. C  NSUB   :  Number of minor ticks between major ticks. If 0 on input
  14192. C            will be set here.
  14193. C
  14194. C 10-Jun-1993 - new routine [nebk]
  14195. C-----------------------------------------------------------------------
  14196.       INTEGER I, NSUBD
  14197.       REAL DMIN, DIFF
  14198. C----------------------------------------------------------------------
  14199.       NSUBD = NSUB
  14200.       DMIN = 1.0E30
  14201.       DO 100 I = 1, NTICKS
  14202.         DIFF = ABS(TOCK - TICKS(I))
  14203.         IF (DIFF.LT.DMIN) THEN
  14204.           TICK = TICKS(I)
  14205.           IF (NSUBD.EQ.0) NSUB = NSUBS(I)
  14206.           ITICK = I
  14207. C
  14208.           DMIN = DIFF
  14209.         END IF
  14210.  100  CONTINUE
  14211. C
  14212.       RETURN
  14213.       END
  14214. C PGTBX3 -- support routine for PGTBOX
  14215. C
  14216.       SUBROUTINE PGTBX3 (DODAY, NPL, TSCALE, TINTS, NTICMX, NTICKS,
  14217.      *                   TICKS, NSUBS, ITICK, AXIS, DOPARA, STR,
  14218.      *                   TICK, NSUB)
  14219. C
  14220.       INTEGER TSCALE, NTICMX, NTICKS, ITICK, NSUB, NSUBS(NTICKS), NPL
  14221.       REAL TINTS, TICKS(NTICKS), TICK
  14222.       CHARACTER AXIS*1, STR*(*)
  14223.       LOGICAL DODAY, DOPARA
  14224. C
  14225. C Try to see if label overwrite is going to occur with this tick 
  14226. C selection, or if there are going to be more than a reasonable
  14227. C number of ticks in the displayed time range.  If so, choose, 
  14228. C if available, the next tick (bigger separation) up in the list.
  14229. C If the overwrite requires that we would need to go up to the bext
  14230. C TSCALE, give up.  They will need to choose a smaller character size
  14231. C
  14232. C This is a support routine for PGTBOX and should not 
  14233. C be called by the user.
  14234. C
  14235. C Input:
  14236. C  DODAY  :  True if day field being used
  14237. C  NPL    :  Number of characters needed to format TICK on input
  14238. C  TSCALE :  Dictates what the finest units of the labelling are.
  14239. C            1 = sec, 60 = min, 3600 = hr, 24*3600 = days
  14240. C  TINTS  :  Absolute time interval in units of TSCALE
  14241. C  NTICMX :  Max. reasonable number of ticks to allow in the time range
  14242. C  NTICKS :  Number of ticks in list of ticks to choose from
  14243. C  TICKS  :  List of ticks from which the current tick was chosen
  14244. C  NSUBS  :  List of number of minor ticks/major tick to choose NSUB from
  14245. C  ITICK  :  Index of chosen tick in list TICKS
  14246. C  AXIS   :  'X' or 'Y' axis
  14247. C  DOPARA :  Labels parallel or perpendicualr to axis
  14248. C  STR    :  A typical formatted string used for checking overwrite
  14249. C Input/output:
  14250. C  TICK   :  Current major tick interval in units of TSCALE. May be 
  14251. C            made larger if possible if overwrite likely.
  14252. C  NSUB   :  Number of minor ticks between major ticks. 
  14253. C
  14254. C 10-Jun-1993 - new routine [nebk]
  14255. C-----------------------------------------------------------------------
  14256.       INTEGER NTICK
  14257.       REAL LENS, LENX, LENY
  14258. C----------------------------------------------------------------------
  14259.       CALL PGLEN (4, STR, LENX, LENY)
  14260.       LENS = LENX
  14261.       IF ( (DOPARA .AND. AXIS.EQ.'Y') .OR.
  14262.      *     (.NOT.DOPARA .AND. AXIS.EQ.'X') ) LENS = LENY
  14263. C
  14264.       IF (TSCALE.EQ.1 .OR. TSCALE.EQ.60 .OR.
  14265.      *    (TSCALE.EQ.3600 .AND. DODAY)) THEN
  14266. C
  14267. C  Time in seconds or minutes, or in hours with a day field
  14268. C
  14269.         NTICK = INT(TINTS / TICK)
  14270.         IF ( (ITICK.LT.NTICKS)  .AND. 
  14271.      *       ((DOPARA .AND. (LENS/TSCALE).GT.0.9*TICK) .OR. 
  14272.      *       (NTICK.GT.NTICMX)) ) THEN
  14273.           IF (TICKS(ITICK+1).LT.TINTS) THEN
  14274.             NSUB = NSUBS(ITICK+1)
  14275.             TICK = TICKS(ITICK+1)
  14276.           END IF
  14277.         END IF
  14278.       ELSE
  14279. C
  14280. C  Time in hours and no day field or time in days
  14281. C
  14282.         NTICK = INT(TINTS / TICK)
  14283.         IF ( (DOPARA .AND. (LENS/TSCALE).GT.0.9*TICK) .OR. 
  14284.      *       (NTICK.GT.NTICMX) ) THEN
  14285.           IF (ITICK.LT.NTICKS) THEN
  14286.             IF (TICKS(ITICK+1)*10**(NPL-1).LT.TINTS) THEN
  14287.               NSUB = NSUBS(ITICK+1)
  14288.               TICK = TICKS(ITICK+1) * 10**(NPL-1)
  14289.             END IF
  14290.           ELSE
  14291.             IF (TICKS(1)*10**NPL.LT.TINTS) THEN
  14292.               NSUB = NSUBS(1)
  14293.               TICK = TICKS(1) * 10**NPL
  14294.             END IF
  14295.           END IF
  14296.         END IF
  14297.       END IF
  14298. C
  14299.       RETURN
  14300.       END
  14301. C PGTBX4 -- support routine for PGTBOX
  14302. C
  14303.       SUBROUTINE PGTBX4 (DODAY, SUPTYP, AXIS, CONVTL, FIRST, TMIN,
  14304.      *                   TMAX, TSCALE, TICK, DO2, DOPARA, MOD24)
  14305. C
  14306.       REAL TMIN, TMAX, TICK
  14307.       INTEGER TSCALE
  14308.       CHARACTER AXIS*(*), SUPTYP*(*)
  14309.       LOGICAL FIRST, DODAY, CONVTL, DO2, DOPARA, MOD24
  14310. C
  14311. C Label an axis in (DD) HH MM SS.S style.    This is the main 
  14312. C workhorse of the PGTBOX routines.
  14313. C
  14314. C This is a support subroutine for PGTBOX and should not be 
  14315. C called by the user. 
  14316. C
  14317. C Inputs:
  14318. C  DODAY  :  Write labels as DD HH MM SS.S else HH MM SS.S with
  14319. C            hours ranging above 24.  Useful for declination labels
  14320. C  SUPTYP :  If 'DHMS' then superscript the fields with d, h, m, & s
  14321. C            If ' DMS' then superscript the fields with    o, '  & '' 
  14322. C              Good for declination plots.  You should obviously not 
  14323. C              ask for the day field for this to do anything sensible. 
  14324. C            If '    ' then no superscripting is done.
  14325. C  AXIS   :  'X' for x-axis, 'Y' for y-axis
  14326. C  CONVTL :  If .true., write the labels in the conventional axis 
  14327. C            locations (bottom and left for 'X' and 'Y').  Otherwise
  14328. C            write them on the top and right axes ('X' and 'Y')
  14329. C  FIRST  :  If .false. then omit the first label.
  14330. C  TMIN   :  Start time (seconds)
  14331. C  TMAX   :  End time (seconds)
  14332. C  TSCALE :  Determines finest units of axis
  14333. C              1 => ss, 60 => mm, 3600 => hh, 3600*24 => dd
  14334. C  TICK   :  Major tick interval in seconds
  14335. C  DO2    :  If .true., write labels less than 10 with a leading zero.
  14336. C  DOPARA :  Y axis label parallel to axis, else perpendicular
  14337. C  MOD24  :  HH field labelled as modulo 24
  14338. C
  14339. C 05-Sep-1988 - new routine (Neil Killeen)
  14340. C 20-Apr-1991 - add support for new DD (day) field [nebk]
  14341. C 10-Jun-1993 - complete rewrite & rename from PGTLAB. Fixes user given 
  14342. C               ticks bug too [nebk]
  14343. C 15-Jan-1995 - Add argument MOD24
  14344. C-----------------------------------------------------------------------
  14345.       INTEGER MAXTIK
  14346.       LOGICAL T, F
  14347.       PARAMETER (MAXTIK = 1000, T = .TRUE., F = .FALSE.)
  14348. C
  14349.       REAL SS(MAXTIK), TFRAC(MAXTIK)
  14350.       INTEGER DD(MAXTIK), HH(MAXTIK), MM(MAXTIK)
  14351.       CHARACTER*1 ASIGN(MAXTIK), ASIGNL
  14352. C
  14353.       REAL TIME, XLEN, YLEN, COORD, FJUST, RVAL, SSL, DISP,
  14354.      *XLEN2, YLEN2
  14355.       INTEGER IS, SD, NT, IZERO, IPOS, INEG, IT, I, J, K, SPREC,
  14356.      *JST(2), JEND(2), TLEN, LAST, IVAL(3), IVALO(3), IVALZ(3),
  14357.      *IVALF(3), IVALL(3), NPASS, INC, DDL, HHL, MML
  14358.       CHARACTER SIGNF*1, TEXT*80, AXLOC*2
  14359.       LOGICAL WRIT(4)
  14360. C-----------------------------------------------------------------------
  14361.       CALL PGBBUF
  14362. C
  14363. C  Direction signs
  14364. C
  14365.       SD = 1
  14366.       IF (TMAX.LT.TMIN) SD = -1
  14367.       IS = 1
  14368.       IF (TMIN.LT.0.0) IS = -1
  14369. C
  14370. C  Find first tick.  Return if none.
  14371. C
  14372.       NT = TMIN / TICK
  14373.       IF (IS*SD.EQ.1 .AND. ABS(TMIN).GT.ABS(NT)*TICK) NT = NT + SD
  14374.       TIME = NT * TICK
  14375.       IF ( (SD.EQ. 1.AND.(TIME.LT.TMIN.OR.TIME.GT.TMAX)) .OR.
  14376.      *     (SD.EQ.-1.AND.(TIME.GT.TMIN.OR.TIME.LT.TMAX)) ) RETURN
  14377. C
  14378. C  Now step through time range in TICK increments and convert
  14379. C  times in seconds at each tick to  +/- (DD) HH MM SS.S
  14380. C
  14381.       IZERO = 0
  14382.       IT = 1
  14383.  100  IF ( (SD.EQ.1  .AND. TIME.GT.(TMAX+1.0E-5)) .OR.
  14384.      *     (SD.EQ.-1 .AND. TIME.LT.(TMAX-1.0E-5)) ) GOTO 200
  14385.         IF (IT.GT.MAXTIK) THEN
  14386.           CALL GRWARN ('PGTBX4: storage exhausted -- you have'
  14387.      *                 //'asked for far too many ticks')
  14388.           GOTO 200
  14389.         END IF
  14390. C
  14391. C  Convert to (DD) HH MM SS.S and find fraction of window that this
  14392. C  tick falls at
  14393. C
  14394.         CALL PGTBX5 (DODAY, TIME, ASIGN(IT), DD(IT), HH(IT),
  14395.      *               MM(IT), SS(IT))
  14396.         TFRAC(IT) = (TIME - TMIN) / (TMAX - TMIN)
  14397. C
  14398. C  Note zero tick
  14399. C
  14400.         IF (NT.EQ.0) IZERO = IT
  14401. C
  14402. C  Increment time
  14403. C
  14404.         NT = NT + SD
  14405.         TIME = NT * TICK
  14406.         IT = IT + 1
  14407. C
  14408.         GOTO 100
  14409.  200  CONTINUE
  14410.       IT = IT - 1
  14411. C
  14412. C   Work out the precision with which to write fractional seconds 
  14413. C   labels into the SS.S field.   All other fields have integer labels.
  14414. C
  14415.       SPREC = 0
  14416.       IF (TSCALE.EQ.1) THEN
  14417.         IF (TICK.LT.0.01) THEN
  14418.           SPREC = 3
  14419.         ELSE IF (TICK.LT.0.1) THEN
  14420.           SPREC = 2
  14421.         ELSE IF (TICK.LT.1.0) THEN
  14422.           SPREC = 1
  14423.         END IF
  14424.       END IF
  14425. C
  14426. C  Label special case of first tick.  Prepare fields and label
  14427. C
  14428.       CALL PGTBX6 (DODAY, MOD24, TSCALE, DD(1), HH(1), MM(1), 
  14429.      *             SS(1), IVALF, RVAL, WRIT)
  14430.       SIGNF = 'H'
  14431.       IF (DODAY) SIGNF = 'D'
  14432.       CALL PGTBX7 (SUPTYP, SIGNF, ASIGN(1), IVALF, RVAL, WRIT,
  14433.      *             SPREC, DO2, TEXT, TLEN, LAST)
  14434. C
  14435. C   Set label displacements from axes.  This is messy for labels oriented
  14436. C   perpendicularly on the right hand axis as we need to know how long
  14437. C   the longest string we are going to write is before we write any 
  14438. C   labels as they are right justified.
  14439. C
  14440.       IF (AXIS.EQ.'X') THEN
  14441.         IF (CONVTL) THEN
  14442.           AXLOC = 'B'
  14443.           IF (SUPTYP.NE.'NONE') THEN
  14444.             DISP = 1.4
  14445.           ELSE
  14446.             DISP = 1.2
  14447.           END IF
  14448.         ELSE
  14449.           AXLOC = 'T'
  14450.           DISP = 0.7
  14451.         END IF
  14452.       ELSE IF (AXIS.EQ.'Y') THEN
  14453.         IF (CONVTL) THEN
  14454.           AXLOC = 'LV'
  14455.           IF (DOPARA) AXLOC = 'L'
  14456.           DISP = 0.7
  14457.         ELSE
  14458.           IF (DOPARA) THEN
  14459.             AXLOC = 'R'
  14460.             IF (SUPTYP.NE.'NONE') THEN
  14461.               DISP = 1.7
  14462.             ELSE
  14463.               DISP = 1.9
  14464.             END IF
  14465.           ELSE
  14466. C
  14467. C  Work out number of characters in first label
  14468. C
  14469.             AXLOC = 'RV'
  14470.             IF (ASIGN(1).NE.'-' .AND. TMIN*TMAX.LT.0.0) THEN
  14471.               CALL PGLEN (2, ' -'//TEXT(1:TLEN), XLEN, YLEN)
  14472.             ELSE
  14473.               CALL PGLEN (2, ' '//TEXT(1:TLEN), XLEN, YLEN)
  14474.             END IF
  14475.             CALL PGQCS (2, XLEN2, YLEN2)
  14476.             DISP = (XLEN/XLEN2)
  14477.           END IF
  14478.         END IF
  14479.       END IF
  14480. C
  14481. C  Now write the label to the plot.  The X-axis label for the first tick is
  14482. C  centred such that the last field of the label is centred on the tick
  14483. C
  14484.       IF (FIRST) THEN
  14485.         CALL PGLEN (5, TEXT(LAST:TLEN), XLEN, YLEN)
  14486. C
  14487.         IF (AXIS.EQ.'X') THEN
  14488.           COORD = TFRAC(1) + XLEN / 2.0
  14489.           FJUST = 1.0
  14490.         ELSE IF (AXIS.EQ.'Y') THEN
  14491.           IF (DOPARA) THEN
  14492.             COORD = TFRAC(1) + YLEN / 2.0
  14493.             FJUST = 1.0
  14494.           ELSE
  14495.             FJUST = 1.0
  14496.             COORD = TFRAC(1)
  14497.           END IF
  14498.         END IF
  14499.         CALL PGMTXT (AXLOC, DISP, COORD, FJUST, TEXT(1:TLEN))
  14500.       END IF
  14501.       IF (IT.EQ.1) RETURN
  14502. C
  14503. C   Designate which field out of DD or HH will carry the sign, depending
  14504. C   on whether you want the day field or not for the rest of the ticks
  14505. C
  14506.       SIGNF = 'H'
  14507.       IF (DODAY) SIGNF = 'D'
  14508. C
  14509. C  Set up labelling justifications for the rest of the labels
  14510. C
  14511.       IF (AXIS.EQ.'X') THEN
  14512.         FJUST = 0.5
  14513.       ELSE IF (AXIS.EQ.'Y') THEN
  14514.         IF (DOPARA) THEN
  14515.           FJUST = 0.5
  14516.         ELSE
  14517.           FJUST = 1.0
  14518.         END IF
  14519.       END IF
  14520. C
  14521. C  Note zero crossings; IPOS is the first positive tick and
  14522. C  INEG is the first negative tick on either side of 0
  14523. C
  14524.       IPOS = 0
  14525.       INEG = 0
  14526. C
  14527.       IF (IZERO.NE.0) THEN
  14528.         J = IZERO - 1
  14529.         IF (J.GE.1) THEN
  14530.           IF (ASIGN(J).EQ.'-') THEN
  14531.             INEG = J
  14532.           ELSE IF (ASIGN(J).EQ.' ') THEN
  14533.             IPOS = J
  14534.           END IF
  14535.         END IF
  14536.         J = IZERO + 1
  14537.         IF (J.LE.IT) THEN
  14538.           IF (ASIGN(J).EQ.'-') THEN
  14539.             INEG = J
  14540.           ELSE IF (ASIGN(J).EQ.' ') THEN
  14541.             IPOS = J
  14542.           END IF
  14543.         END IF
  14544.       END IF
  14545. C
  14546. C  Now label special case of zero tick. It carries the sign change
  14547. C  when going from positive to negative time, left to right.
  14548. C
  14549.       IF (IZERO.NE.0 .AND. IZERO.NE.1) THEN
  14550.         CALL PGTBX6 (DODAY, MOD24, TSCALE, DD(IZERO), HH(IZERO), 
  14551.      *               MM(IZERO), SS(IZERO), IVALZ, RVAL, WRIT)
  14552. C
  14553.         IF (ASIGN(IZERO-1).EQ.' ') ASIGN(IZERO) = '-'
  14554.         CALL PGTBX7 (SUPTYP, SIGNF, ASIGN(IZERO), IVALZ, RVAL, WRIT,
  14555.      *               SPREC, DO2, TEXT, TLEN, LAST)
  14556. C
  14557.         COORD = TFRAC(IZERO)
  14558.         CALL PGMTXT (AXLOC, DISP, COORD, FJUST, TEXT(1:TLEN))
  14559.       END IF
  14560. C
  14561. C   We may need an extra "virtual" tick if there is no zero crossing
  14562. C   and SD=-1 & IS=1 or SD=1 & IS=-1.  It is used to work out which
  14563. C   fields to label on the right most tick which is labelled first.
  14564. C
  14565.       IF (IZERO.EQ.0) THEN
  14566.         IF (SD*IS.EQ.-1) THEN 
  14567.           IF ( (SD.EQ.-1 .AND. TIME.LE.0.0) .OR.
  14568.      *         (SD.EQ. 1 .AND. TIME.GE.0.0) ) TIME = 0.0
  14569.           CALL PGTBX5 (DODAY, TIME, ASIGNL, DDL, HHL, MML, SSL)
  14570.           CALL PGTBX6 (DODAY, MOD24, TSCALE, DDL, HHL, MML, SSL,
  14571.      *                 IVALL, RVAL, WRIT)
  14572.         END IF
  14573.       END IF
  14574. C
  14575. C  We want to label in the direction(s) away from zero, so we may  need
  14576. C  two passes. Determine the start and end ticks for each required pass.
  14577. C
  14578.       JST(2) = 0
  14579.       JEND(2) = 0
  14580.       NPASS = 1
  14581.       IF (IZERO.EQ.0) THEN
  14582.         IF (IS*SD.EQ.1) THEN
  14583.           JST(1) = 1
  14584.           JEND(1) = IT
  14585.         ELSE
  14586.           JST(1) = IT
  14587.           JEND(1) = 1
  14588.         END IF
  14589.       ELSE
  14590.         IF (INEG.EQ.0 .OR. IPOS.EQ.0) THEN
  14591.           JST(1) = IZERO
  14592.           JEND(1) = IT
  14593.           IF (IZERO.EQ.IT) JEND(1) = 1
  14594.         ELSE
  14595.           NPASS = 2
  14596.           JST(1) = IZERO
  14597.           JEND(1) = 1
  14598.           JST(2) = IZERO
  14599.           JEND(2) = IT
  14600.         END IF
  14601.       END IF
  14602. C
  14603. C  Now label the rest of the ticks.  Always label away from 0
  14604. C
  14605.       DO 400 I = 1, NPASS
  14606. C
  14607. C  Initialize previous tick values.  Use virtual tick if labelling
  14608. C  left to right without a zero (one pass)
  14609. C
  14610.         DO 250 K = 1, 3
  14611.           IVALO(K) = IVALZ(K)
  14612.           IF (IZERO.EQ.0) THEN
  14613.             IVALO(K) = IVALL(K)
  14614.             IF (JST(I).EQ.1) IVALO(K) = IVALF(K)
  14615.           END IF
  14616.   250   CONTINUE
  14617. C
  14618.         INC = 1
  14619.         IF (JEND(I).LT.JST(I)) INC = -1
  14620.         DO 300 J = JST(I), JEND(I), INC
  14621. C
  14622. C  First and zero tick already labelled
  14623. C
  14624.           IF (J.NE.1 .AND. J.NE.IZERO) THEN
  14625. C
  14626. C  Prepare fields
  14627. C
  14628.             CALL PGTBX6 (DODAY, MOD24, TSCALE, DD(J), HH(J), MM(J),
  14629.      *                   SS(J), IVAL, RVAL, WRIT)
  14630. C
  14631. C  Don't write unchanging fields
  14632. C
  14633.             DO 275 K = 1, 3
  14634.               IF (IVAL(K).EQ.IVALO(K)) WRIT(K) = F
  14635.  275        CONTINUE
  14636. C
  14637. C  Prepare label
  14638. C
  14639.             CALL PGTBX7 (SUPTYP, SIGNF, ASIGN(J), IVAL, RVAL, WRIT,
  14640.      *                   SPREC, DO2, TEXT, TLEN, LAST)
  14641. C
  14642. C  Write label
  14643. C
  14644.             COORD = TFRAC(J)
  14645.             CALL PGMTXT (AXLOC, DISP, COORD, FJUST, TEXT(1:TLEN))
  14646. C
  14647. C  Update old values
  14648. C
  14649.             DO 280 K = 1, 3
  14650.               IVALO(K) = IVAL(K)
  14651.   280       CONTINUE
  14652.           END IF
  14653.  300    CONTINUE
  14654.  400  CONTINUE
  14655.       CALL PGEBUF
  14656. C 
  14657.       RETURN
  14658.       END
  14659. C PGTBX5 -- support routine for PGTBOX
  14660. C
  14661.       SUBROUTINE PGTBX5 (DODAY, TSEC, ASIGN, D, H, M, S)
  14662. C      
  14663.       REAL S, TSEC
  14664.       INTEGER  D, H, M
  14665.       LOGICAL DODAY
  14666.       CHARACTER*1 ASIGN
  14667. C
  14668. C  Convert time in seconds to (DD) HH MM SS.S
  14669. C
  14670. C Input
  14671. C  DODAY  :  Use day field if true, else hours accumulates beyond 24
  14672. C  TSEC   :  Time in seconds (signed)
  14673. C Output
  14674. C  ASIGN  :  Sign, ' ' or '-'
  14675. C  D,H,M  :  DD, HH, MM (unsigned)
  14676. C  S      :  SS.S       (unsigned)
  14677. C
  14678. C 10-Jun-1993 - new routine [nebk]
  14679. C-----------------------------------------------------------------------
  14680.       INTEGER IT
  14681. C----------------------------------------------------------------------
  14682.       ASIGN = ' '
  14683.       IF (TSEC.LT.0.0) ASIGN = '-'
  14684. C
  14685.       S = MOD(ABS(TSEC),60.0)
  14686. C
  14687.       IT = NINT(ABS(TSEC)-S) / 60
  14688.       M = MOD(IT,60)
  14689. C
  14690.       IT = (IT - M) / 60
  14691.       IF (DODAY) THEN
  14692.         H = MOD(IT,24)
  14693.         D = (IT-H) / 24
  14694.       ELSE
  14695.         H = IT
  14696.         D = 0
  14697.       END IF
  14698. C
  14699.       RETURN
  14700.       END
  14701. C PGTBX6 -- support routine for PGTBOX
  14702. C
  14703.       SUBROUTINE PGTBX6 (DODAY, MOD24, TSCALE, DD, HH, MM, SS, IVAL, 
  14704.      *                   RVAL, WRIT)
  14705. C
  14706.       INTEGER TSCALE, IVAL(3), DD, HH, MM
  14707.       REAL SS, RVAL
  14708.       LOGICAL WRIT(4), DODAY, MOD24
  14709. C
  14710. C   Find out which of the DD HH MM SS.S fields we want to write
  14711. C   into the label according to TSCALE and make a round off
  14712. C   error check.
  14713. C
  14714. C  Input:
  14715. C    DODAY  :  Use day field if true else hours accrue beyond 24
  14716. C    MOD24  :  HH field labelled as modulo 24
  14717. C    TSCALE :  Dictates which fields appear in labels
  14718. C    DD     :  Day of time  (will be 0 if DODAY=F and HH will compensate)
  14719. C    HH     :  Hour of time
  14720. C    MM     :  Minute of time
  14721. C    SS     :  Second of time
  14722. C  Output:
  14723. C    IVAL(3):  DD HH MM to write into label
  14724. C    RVAL   :  SS.S to write into label
  14725. C    WRIT(4):  T or F if DD,HH,MM,SS are to be written into the label
  14726. C              or not.  IVAL and RVAL fields are set explicitly to
  14727. C              zero if the corresponding WRIT field is false.
  14728. C              This really is overkill.
  14729. C
  14730. C  10-Jun-1993 - New routine [nebk]
  14731. C  16-Jan-1995 - Add argument MOD24
  14732. C-----------------------------------------------------------------------
  14733.       LOGICAL T, F
  14734.       PARAMETER (T = .TRUE., F = .FALSE.)
  14735.       INTEGER WM
  14736. C-----------------------------------------------------------------------
  14737.       IVAL(1) = DD
  14738.       IVAL(2) = HH
  14739.       IVAL(3) = MM
  14740.       RVAL    = SS
  14741. C
  14742. C  SS should be 0.0; round off may get us 59.999 or the like but
  14743. C  not 60.001 (see PGTBX5)
  14744. C
  14745.       IF (TSCALE.GT.1) THEN
  14746.         WM = NINT(SS/60.0)
  14747.         IVAL(3) = IVAL(3) + WM
  14748.         IF (IVAL(3).EQ.60) THEN
  14749.           IVAL(3) = 0
  14750.           IVAL(2) = IVAL(2) + 1
  14751.           IF (DODAY .AND. IVAL(2).EQ.24) THEN
  14752.             IVAL(2) = 0
  14753.             IVAL(1) = IVAL(1) + 1
  14754.           END IF
  14755.         END IF
  14756.       END IF
  14757. C
  14758. C Make HH field modulo 24 if desired
  14759. C
  14760.       IF (MOD24) IVAL(2) = MOD(IVAL(2),24)
  14761. C
  14762.       IF (TSCALE.EQ.1) THEN
  14763. C
  14764. C  Label contains (DD) HH MM SS.S
  14765. C
  14766.         WRIT(1) = DODAY
  14767.         WRIT(2) = T
  14768.         WRIT(3) = T
  14769.         WRIT(4) = T
  14770.       ELSE IF (TSCALE.EQ.60) THEN
  14771. C
  14772. C  Label contains (DD) HH MM
  14773. C
  14774.         WRIT(1) = DODAY
  14775.         WRIT(2) = T
  14776.         WRIT(3) = T
  14777. C        
  14778.         RVAL    = 0.0
  14779.         WRIT(4) = F
  14780.       ELSE IF (TSCALE.EQ.3600) THEN
  14781. C
  14782. C  Label contains (DD) HH
  14783. C
  14784.         WRIT(1) = DODAY
  14785.         WRIT(2) = T
  14786. C
  14787.         IVAL(3) = 0
  14788.         WRIT(3) = F
  14789. C  
  14790.         RVAL    = 0.0
  14791.         WRIT(4) = F
  14792.       ELSE IF (TSCALE.EQ.3600*24) THEN
  14793. C
  14794. C  Label contains DD
  14795. C
  14796.         WRIT(1) = T
  14797. C
  14798.         IVAL(2) = 0
  14799.         WRIT(2) = F
  14800. C
  14801.         IVAL(3) = 0
  14802.         WRIT(3) = F
  14803. C
  14804.         RVAL    = 0.0
  14805.         WRIT(4) = F
  14806.       END IF
  14807. C
  14808.       RETURN
  14809.       END
  14810.       SUBROUTINE PGTBX7 (SUPTYP, SIGNF, ASIGN, IVAL, RVAL, WRIT,
  14811.      *                   SPREC, DO2, TEXT, TLEN, LAST)
  14812. C
  14813.       REAL RVAL
  14814.       INTEGER IVAL(3), TLEN, SPREC, LAST
  14815.       CHARACTER ASIGN*1, TEXT*(*), SIGNF*1, SUPTYP*4
  14816.       LOGICAL WRIT(4), DO2
  14817. C
  14818. C Write (DD) HH MM SS.S time labels into a string
  14819. C
  14820. C This is a support routine for PGTBOX and should not be
  14821. C called by the user
  14822. C
  14823. C Inputs
  14824. C  SUPTYP :  '    ', 'DHMS', or ' DMS' for no superscript labelling,
  14825. C            d,h,m,s   or   o,','' superscripting
  14826. C  SIGNF  :  Tells which field the sign is associated with.  
  14827. C            One of 'D', 'H', 'M', or 'S'    
  14828. C  ASIGN  :  ' ' or '-' for positive or negative times
  14829. C  IVAL(3):  Day, hour, minutes of time
  14830. C  RVAL   :  Seconds of time
  14831. C  WRIT(4):  If .true. then write DD, HH, MM, SS  into label
  14832. C  SPREC  :  Number of places after the decimal to write seconds 
  14833. C            string to.  Must be in the range 0-3
  14834. C  DO2    :  If true, add a leading zero to numbers < 10
  14835. C Outputs
  14836. C  TEXT   :  Label
  14837. C  TLEN   :  Length of label
  14838. C  LAST   :  Is the location of the start character of the last 
  14839. C            field written into TEXT
  14840. C
  14841. C  05-Sep-1989 -- New routine (Neil Killeen)
  14842. C  20-Apr-1991 -- Complete rewrite; support for new DD (day) field and 
  14843. C                 superscripted labels [nebk]
  14844. C  14-May-1991 -- Removed BSL as a parameter (Char(92)) and made it
  14845. C                 a variable to appease Cray compiler [mjs/nebk]
  14846. C  10-Jun-1993 -- Rename from PGTLB1, add code to label superscript 
  14847. C                 seconds above the '.' and add DO2 option [nebk/jm]
  14848. C-----------------------------------------------------------------------
  14849.       INTEGER FLEN, FST, FMAX, TRLEN(3), SUPPNT, TMPNT, TLEN2, 
  14850.      *IR1, IR2, IP
  14851.       CHARACTER FIELD*30, FRMAT2(3)*2, SUPER(4,3)*11, TMP*100, 
  14852.      *BSL*1, FRMAT*30
  14853. C
  14854.       SAVE FRMAT2
  14855.       SAVE TRLEN
  14856. C
  14857.       DATA FRMAT2 /'I1', 'I2', 'I3'/
  14858.       DATA TRLEN /5, 11, 5/
  14859. C-----------------------------------------------------------------------
  14860. C
  14861. C   Initialize
  14862. C
  14863.       BSL = CHAR(92)
  14864.       TLEN = 0
  14865.       TEXT = ' '
  14866. C
  14867. C   Assign superscripting strings.  Use CHAR(92) for backslash as the
  14868. C   latter must be escaped on SUNs thus requiring preprocessing.  The
  14869. C   concatenator operator precludes the use of a data statement
  14870. C
  14871.       SUPER(1,1) = BSL//'ud'//BSL//'d'
  14872.       SUPER(2,1) = BSL//'uh'//BSL//'d'
  14873.       SUPER(3,1) = BSL//'um'//BSL//'d'
  14874.       SUPER(4,1) = BSL//'us'//BSL//'d'
  14875. C
  14876.       SUPER(1,2) = BSL//'u'//BSL//'(2199)'//BSL//'d'
  14877.       SUPER(2,2) = BSL//'u'//BSL//'(2729)'//BSL//'d'
  14878.       SUPER(3,2) = BSL//'u'//BSL//'(2727)'//BSL//'d'
  14879.       SUPER(4,2) = BSL//'u'//BSL//'(2728)'//BSL//'d'
  14880. C      
  14881.       SUPER(1,3) = BSL//'u'//' '//BSL//'d'
  14882.       SUPER(2,3) = BSL//'u'//' '//BSL//'d'
  14883.       SUPER(3,3) = BSL//'u'//' '//BSL//'d'
  14884.       SUPER(4,3) = BSL//'u'//' '//BSL//'d'
  14885. C
  14886. C   Point at correct superscript strings
  14887. C
  14888.       IF (SUPTYP.EQ.'DHMS') THEN
  14889.         SUPPNT = 1
  14890.       ELSE IF (SUPTYP.EQ.' DMS') THEN
  14891.         SUPPNT = 2
  14892.       ELSE
  14893.         SUPPNT = 3
  14894.       END IF
  14895. C
  14896. CCCC
  14897. C   Days field
  14898. CCCC
  14899. C
  14900.       IF (WRIT(1)) THEN
  14901.         LAST = TLEN + 1
  14902. C
  14903. C   Write into temporary field
  14904. C
  14905.         FIELD = ' '
  14906.         CALL PGNPL (0, IVAL(1), FLEN)
  14907.         WRITE (FIELD, '(I6)') IVAL(1)
  14908.         FMAX = 6
  14909.         FST = FMAX - FLEN + 1
  14910. C
  14911. C   Write output text string with desired superscripting
  14912. C
  14913.         TMPNT = 2
  14914.         IF (SIGNF.EQ.'D' .AND. ASIGN.NE.' ') TMPNT = 1
  14915. C
  14916.         TMP = ASIGN//FIELD(FST:FMAX)//SUPER(1,SUPPNT)
  14917.         TLEN2 = (2 - TMPNT) + FLEN + TRLEN(SUPPNT)
  14918. C
  14919.         TEXT(TLEN+1:) = TMP(TMPNT:TMPNT+TLEN2-1)
  14920.         TLEN = TLEN + TLEN2
  14921.       END IF
  14922. C
  14923. CCCC 
  14924. C   Hours field
  14925. CCCC
  14926. C
  14927.       IF (WRIT(2)) THEN
  14928.         LAST = TLEN + 1
  14929. C
  14930. C   Write into temporary field
  14931. C
  14932.         FIELD = ' '
  14933.         CALL PGNPL (0, IVAL(2), FLEN)
  14934.         WRITE (FIELD, '(I6)') IVAL(2)
  14935.         FMAX = 6
  14936.         FST = FMAX - FLEN + 1
  14937. C
  14938.         IF (DO2 .AND. FLEN.EQ.1) THEN
  14939.           FLEN = FLEN + 1
  14940.           FST = FST - 1
  14941.           FIELD(FST:FST) = '0'
  14942.         END IF
  14943. C
  14944. C   Write output text string with desired superscripting
  14945. C
  14946.         TMPNT = 2
  14947.         IF (SIGNF.EQ.'H' .AND. ASIGN.NE.' ') TMPNT = 1
  14948. C
  14949.         TMP = ASIGN//FIELD(FST:FMAX)//SUPER(2,SUPPNT)
  14950.         TLEN2 = (2 - TMPNT) + FLEN + TRLEN(SUPPNT)
  14951. C
  14952.         TEXT(TLEN+1:) = TMP(TMPNT:TMPNT+TLEN2-1)
  14953.         TLEN = TLEN + TLEN2
  14954.       END IF
  14955. C
  14956. CCCC
  14957. C   Minutes field
  14958. CCCC
  14959. C
  14960.       IF (WRIT(3)) THEN
  14961.         LAST = TLEN + 1
  14962. C
  14963. C   Write into temporary field with desired superscripting
  14964. C
  14965.         FIELD = ' '
  14966.         WRITE (FIELD, '(I2, A)') IVAL(3), 
  14967.      *                           SUPER(3,SUPPNT)(1:TRLEN(SUPPNT))
  14968.         FMAX = 2 + TRLEN(SUPPNT)
  14969. C
  14970.         FST = 1
  14971.         IF (FIELD(FST:FST).EQ.' ') THEN
  14972.           IF (DO2) THEN
  14973.             FIELD(FST:FST) = '0'
  14974.           ELSE
  14975.             FST = FST + 1
  14976.           END IF
  14977.         END IF
  14978.         FLEN = FMAX - FST + 1
  14979. C
  14980. C   Write output text string
  14981. C
  14982.         TMPNT = 2
  14983.         IF (SIGNF.EQ.'M' .AND. ASIGN.NE.' ') TMPNT = 1
  14984. C
  14985.         TMP = ASIGN//FIELD(FST:FMAX)
  14986.         TLEN2 = (2 - TMPNT) + FLEN
  14987. C
  14988.         TEXT(TLEN+1:) = TMP(TMPNT:TMPNT+TLEN2-1)
  14989.         TLEN = TLEN + TLEN2
  14990.       END IF
  14991. C
  14992. CCCC
  14993. C   Seconds field
  14994. CCCC
  14995. C
  14996.       IF (WRIT(4)) THEN
  14997.         LAST = TLEN + 1
  14998. C
  14999. C   Write into temporary field
  15000. C 
  15001.         FIELD = ' '
  15002.         FST = 1
  15003.         IF (SPREC.GE.1) THEN
  15004. C
  15005. C   Fractional label.  Upto 3 places after the decimal point allowed
  15006. C   Muck around to get the superscript on top of the decimal point
  15007. C
  15008.           IR1 = INT(RVAL)
  15009.           IR2 = NINT((RVAL - IR1) * 10**SPREC)
  15010.           FRMAT = '(I2, A1, A, '//FRMAT2(SPREC)//')'
  15011.           WRITE (FIELD, FRMAT(1:15)) 
  15012.      *                       IR1, '.',
  15013.      *                       BSL//'b'//SUPER(4,SUPPNT)(1:TRLEN(SUPPNT)),
  15014.      *                       IR2
  15015.           IP = 5 + TRLEN(SUPPNT) + 1
  15016.           IF (FIELD(IP:IP).EQ.' ') FIELD(IP:IP) = '0'
  15017.           IF (FIELD(IP+1:IP+1).EQ.' ') FIELD(IP+1:IP+1) = '0'
  15018.           FMAX = 1 + 2 + SPREC
  15019.         ELSE
  15020. C
  15021. C   Integer label.  
  15022. C
  15023.           WRITE (FIELD, '(I2,A)') NINT(RVAL), 
  15024.      *                            SUPER(4,SUPPNT)(1:TRLEN(SUPPNT))
  15025.           FMAX = 0
  15026.         END IF
  15027.         FMAX = FMAX + 2 + TRLEN(SUPPNT)
  15028. C
  15029.         IF (FIELD(FST:FST).EQ.' ') THEN
  15030.           IF (DO2) THEN
  15031.             FIELD(FST:FST) = '0'
  15032.           ELSE
  15033.             FST = FST + 1
  15034.           END IF
  15035.         END IF
  15036.         FLEN = FMAX - FST + 1
  15037. C
  15038. C   Write output text string
  15039. C
  15040.         TMPNT = 2
  15041.         IF (SIGNF.EQ.'S' .AND. ASIGN.NE.' ') TMPNT = 1
  15042.         TMP = ASIGN//FIELD(FST:FMAX)
  15043.         TLEN2 = (3 - TMPNT) + FLEN
  15044. C
  15045.         TEXT(TLEN+1:) = TMP(TMPNT:TMPNT+TLEN2-1)
  15046.         TLEN = TLEN + TLEN2
  15047.       END IF
  15048. C  
  15049. C   A trailing blank will occur if no superscripting wanted
  15050. C
  15051.       IF (TLEN.GE.5 .AND. TEXT(TLEN-4:TLEN).EQ.BSL//'u'//' '//BSL//'d')
  15052.      *   TLEN = TLEN - 5
  15053. C      
  15054.       RETURN
  15055.       END
  15056. C*PGTEXT -- write text (horizontal, left-justified)
  15057. C%void cpgtext(float x, float y, const char *text);
  15058. C+
  15059.       SUBROUTINE PGTEXT (X, Y, TEXT)
  15060.       REAL X, Y
  15061.       CHARACTER*(*) TEXT
  15062. C
  15063. C Write text. The bottom left corner of the first character is placed
  15064. C at the specified position, and the text is written horizontally.
  15065. C This is a simplified interface to the primitive routine PGPTXT.
  15066. C For non-horizontal text, use PGPTXT.
  15067. C
  15068. C Arguments:
  15069. C  X      (input)  : world x-coordinate of start of string.
  15070. C  Y      (input)  : world y-coordinate of start of string.
  15071. C  TEXT   (input)  : the character string to be plotted.
  15072. C--
  15073. C (2-May-1983)
  15074. C-----------------------------------------------------------------------
  15075.       CALL PGPTXT(X, Y, 0.0, 0.0, TEXT)
  15076.       END
  15077. C*PGUPDT -- update display
  15078. C%void cpgupdt(void);
  15079. C+
  15080.       SUBROUTINE PGUPDT
  15081. C
  15082. C Update the graphics display: flush any pending commands to the
  15083. C output device. This routine empties the buffer created by PGBBUF,
  15084. C but it does not alter the PGBBUF/PGEBUF counter. The routine should
  15085. C be called when it is essential that the display be completely up to
  15086. C date (before interaction with the user, for example) but it is not
  15087. C known if output is being buffered.
  15088. C
  15089. C Arguments: none
  15090. C--
  15091. C 27-Nov-1986
  15092. C-----------------------------------------------------------------------
  15093.       LOGICAL PGNOTO
  15094. C
  15095.       IF (PGNOTO('PGUPDT')) RETURN
  15096.       CALL GRTERM
  15097.       END
  15098. C*PGVECT -- vector map of a 2D data array, with blanking
  15099. C%void cpgvect(const float *a, const float *b, int idim, int jdim, \
  15100. C% int i1, int i2, int j1, int j2, float c, int nc, \
  15101. C% const float *tr, float blank);
  15102. C+
  15103.       SUBROUTINE PGVECT (A, B, IDIM, JDIM, I1, I2, J1, J2, C, NC, TR,
  15104.      1                   BLANK)
  15105.       INTEGER IDIM, JDIM, I1, I2, J1, J2, NC
  15106.       REAL    A(IDIM,JDIM), B(IDIM, JDIM), TR(6), BLANK, C
  15107. C
  15108. C Draw a vector map of two arrays.  This routine is similar to
  15109. C PGCONB in that array elements that have the "magic value" defined by
  15110. C the argument BLANK are ignored, making gaps in the vector map.  The
  15111. C routine may be useful for data measured on most but not all of the
  15112. C points of a grid. Vectors are displayed as arrows; the style of the
  15113. C arrowhead can be set with routine PGSAH, and the the size of the
  15114. C arrowhead is determined by the current character size, set by PGSCH.
  15115. C
  15116. C Arguments:
  15117. C  A      (input)  : horizontal component data array.
  15118. C  B      (input)  : vertical component data array.
  15119. C  IDIM   (input)  : first dimension of A and B.
  15120. C  JDIM   (input)  : second dimension of A and B.
  15121. C  I1,I2  (input)  : range of first index to be mapped (inclusive).
  15122. C  J1,J2  (input)  : range of second index to be mapped (inclusive).
  15123. C  C      (input)  : scale factor for vector lengths, if 0.0, C will be
  15124. C                    set so that the longest vector is equal to the
  15125. C                    smaller of TR(2)+TR(3) and TR(5)+TR(6).
  15126. C  NC     (input)  : vector positioning code.
  15127. C                    <0 vector head positioned on coordinates
  15128. C                    >0 vector base positioned on coordinates
  15129. C                    =0 vector centered on the coordinates
  15130. C  TR     (input)  : array defining a transformation between the I,J
  15131. C                    grid of the array and the world coordinates. The
  15132. C                    world coordinates of the array point A(I,J) are
  15133. C                    given by:
  15134. C                      X = TR(1) + TR(2)*I + TR(3)*J
  15135. C                      Y = TR(4) + TR(5)*I + TR(6)*J
  15136. C                    Usually TR(3) and TR(5) are zero - unless the
  15137. C                    coordinate transformation involves a rotation
  15138. C                    or shear.
  15139. C  BLANK   (input) : elements of arrays A or B that are exactly equal to
  15140. C                    this value are ignored (blanked).
  15141. C--
  15142. C  4-Sep-1992: derived from PGCONB [J. Crane].
  15143. C 26-Nov-1992: revised to use PGARRO [TJP].
  15144. C 25-Mar-1994: correct error for NC not =0 [G. Gonczi].
  15145. C  5-Oct-1996: correct error in computing max vector length [TJP;
  15146. C              thanks to David Singleton].
  15147. C-----------------------------------------------------------------------
  15148.       INTEGER  I, J
  15149.       REAL X, Y, X1, Y1, X2, Y2
  15150.       REAL CC
  15151.       INTRINSIC SQRT, MAX, MIN
  15152. C
  15153. C Define grid to world transformation
  15154. C
  15155.       X(I,J) = TR(1) + TR(2)*I + TR(3)*J
  15156.       Y(I,J) = TR(4) + TR(5)*I + TR(6)*J
  15157. C
  15158. C Check arguments.
  15159. C
  15160.       IF (I1.LT.1 .OR. I2.GT.IDIM .OR. I1.GE.I2 .OR.
  15161.      1    J1.LT.1 .OR. J2.GT.JDIM .OR. J1.GE.J2) THEN
  15162. C        CALL GRWARN('PGVECT: invalid range I1:I2, J1:J2')
  15163.          RETURN
  15164.       END IF
  15165. C
  15166. C Check for scale factor C.
  15167. C
  15168.       CC = C
  15169.       IF (CC.EQ.0.0) THEN
  15170.          DO 20 J=J1,J2
  15171.             DO 10 I=I1,I2
  15172.                IF (A(I,J).NE.BLANK .AND. B(I,J).NE.BLANK)
  15173.      1              CC = MAX(CC,SQRT(A(I,J)**2+B(I,J)**2))
  15174.  10         CONTINUE
  15175.  20      CONTINUE
  15176.          IF (CC.EQ.0.0) RETURN
  15177.          CC = SQRT(MIN(TR(2)**2+TR(3)**2,TR(5)**2+TR(6)**2))/CC
  15178.       END IF
  15179. C
  15180.       CALL PGBBUF
  15181. C
  15182.       DO 40 J=J1,J2
  15183.          DO 30 I=I1,I2
  15184. C
  15185. C Ignore vector if element of A and B are both equal to BLANK
  15186. C
  15187.             IF (.NOT.(A(I,J).EQ.BLANK .AND. B(I,J).EQ.BLANK)) THEN
  15188.  
  15189. C
  15190. C Define the vector starting and end points according to NC.
  15191. C
  15192.                IF (NC.LT.0) THEN
  15193.                   X2 = X(I,J)
  15194.                   Y2 = Y(I,J)
  15195.                   X1 = X2 - A(I,J)*CC
  15196.                   Y1 = Y2 - B(I,J)*CC
  15197.                ELSE IF (NC.EQ.0) THEN
  15198.                   X2 = X(I,J) + 0.5*A(I,J)*CC
  15199.                   Y2 = Y(I,J) + 0.5*B(I,J)*CC
  15200.                   X1 = X2 - A(I,J)*CC
  15201.                   Y1 = Y2 - B(I,J)*CC
  15202.                ELSE
  15203.                   X1 = X(I,J)
  15204.                   Y1 = Y(I,J)
  15205.                   X2 = X1 + A(I,J)*CC
  15206.                   Y2 = Y1 + B(I,J)*CC
  15207.                END IF
  15208. C     
  15209. C Draw vector.
  15210. C
  15211.                CALL PGARRO(X1, Y1, X2, Y2)
  15212.             END IF
  15213.  30      CONTINUE
  15214.  40   CONTINUE
  15215. C
  15216.       CALL PGEBUF
  15217.       END
  15218. C*PGVPORT -- non-standard alias for PGSVP
  15219. C+
  15220.       SUBROUTINE PGVPORT (XLEFT, XRIGHT, YBOT, YTOP)
  15221.       REAL XLEFT, XRIGHT, YBOT, YTOP
  15222. C
  15223. C See description of PGSVP.
  15224. C--
  15225.       CALL PGSVP (XLEFT, XRIGHT, YBOT, YTOP)
  15226.       END
  15227. C*PGVSIZ -- set viewport (inches)
  15228. C%void cpgvsiz(float xleft, float xright, float ybot, float ytop);
  15229. C+
  15230.       SUBROUTINE PGVSIZ (XLEFT, XRIGHT, YBOT, YTOP)
  15231.       REAL XLEFT, XRIGHT, YBOT, YTOP
  15232. C
  15233. C Change the size and position of the viewport, specifying
  15234. C the viewport in physical device coordinates (inches).  The
  15235. C viewport is the rectangle on the view surface "through"
  15236. C which one views the graph.  All the PG routines which plot lines
  15237. C etc. plot them within the viewport, and lines are truncated at
  15238. C the edge of the viewport (except for axes, labels etc drawn with
  15239. C PGBOX or PGLAB).  The region of world space (the coordinate
  15240. C space of the graph) which is visible through the viewport is
  15241. C specified by a call to PGSWIN.  It is legal to request a
  15242. C viewport larger than the view surface; only the part which
  15243. C appears on the view surface will be plotted.
  15244. C
  15245. C Arguments:
  15246. C  XLEFT  (input)  : x-coordinate of left hand edge of viewport, in
  15247. C                    inches from left edge of view surface.
  15248. C  XRIGHT (input)  : x-coordinate of right hand edge of viewport, in
  15249. C                    inches from left edge of view surface.
  15250. C  YBOT   (input)  : y-coordinate of bottom edge of viewport, in
  15251. C                    inches from bottom of view surface.
  15252. C  YTOP   (input)  : y-coordinate of top  edge of viewport, in inches
  15253. C                    from bottom of view surface.
  15254. C--
  15255. C 13-Dec-1990  Make errors non-fatal [TJP].
  15256. C-----------------------------------------------------------------------
  15257.       INCLUDE  'f77.PGPLOT/IN'
  15258.       LOGICAL  PGNOTO
  15259. C
  15260.       IF (PGNOTO('PGVSIZ'))  RETURN
  15261.       IF (XLEFT.GE.XRIGHT .OR. YBOT.GE.YTOP) THEN
  15262.           CALL GRWARN('PGVSIZ ignored: invalid arguments')
  15263.           RETURN
  15264.       END IF
  15265. C
  15266.       PGXLEN(PGID) = (XRIGHT-XLEFT)*PGXPIN(PGID)
  15267.       PGYLEN(PGID) = (YTOP-YBOT)*PGYPIN(PGID)
  15268.       PGXVP(PGID)  = XLEFT*PGXPIN(PGID)
  15269.       PGYVP(PGID)  = YBOT*PGYPIN(PGID)
  15270.       PGXOFF(PGID) = PGXVP(PGID) + (PGNXC(PGID)-1)*PGXSZ(PGID)
  15271.       PGYOFF(PGID) = PGYVP(PGID) + 
  15272.      1                (PGNY(PGID)-PGNYC(PGID))*PGYSZ(PGID)
  15273.       CALL PGVW
  15274.       END
  15275. C*PGVSIZE -- non-standard alias for PGVSIZ
  15276. C+
  15277.       SUBROUTINE PGVSIZE (XLEFT, XRIGHT, YBOT, YTOP)
  15278.       REAL XLEFT, XRIGHT, YBOT, YTOP
  15279. C
  15280. C See description of PGVSIZ.
  15281. C--
  15282.       CALL PGVSIZ (XLEFT, XRIGHT, YBOT, YTOP)
  15283.       END
  15284. C*PGVSTAND -- non-standard alias for PGVSTD
  15285. C+
  15286.       SUBROUTINE PGVSTAND
  15287. C
  15288. C See description of PGVSTD.
  15289. C--
  15290.       CALL PGVSTD
  15291.       END
  15292. C*PGVSTD -- set standard (default) viewport
  15293. C%void cpgvstd(void);
  15294. C+
  15295.       SUBROUTINE PGVSTD
  15296. C
  15297. C Define the viewport to be the standard viewport.  The standard
  15298. C viewport is the full area of the view surface (or panel),
  15299. C less a margin of 4 character heights all round for labelling.
  15300. C It thus depends on the current character size, set by PGSCH.
  15301. C
  15302. C Arguments: none.
  15303. C--
  15304. C 22-Apr-1983: [TJP].
  15305. C  2-Aug-1995: [TJP].
  15306. C-----------------------------------------------------------------------
  15307.       INCLUDE  'f77.PGPLOT/IN'
  15308.       LOGICAL  PGNOTO
  15309.       REAL     XLEFT, XRIGHT, YBOT, YTOP, R
  15310. C
  15311.       IF (PGNOTO('PGVSIZ')) RETURN
  15312. C
  15313.       R = 4.0*PGYSP(PGID)
  15314.       XLEFT  = R/PGXPIN(PGID)
  15315.       XRIGHT = XLEFT + (PGXSZ(PGID)-2.0*R)/PGXPIN(PGID)
  15316.       YBOT   = R/PGYPIN(PGID)
  15317.       YTOP   = YBOT + (PGYSZ(PGID)-2.0*R)/PGYPIN(PGID)
  15318.       CALL PGVSIZ(XLEFT, XRIGHT, YBOT, YTOP)
  15319.       END
  15320. C
  15321.       SUBROUTINE PGVW
  15322. C
  15323. C PGPLOT (internal routine): set the GRPCKG scaling transformation
  15324. C and window appropriate for the current window and viewport. This
  15325. C routine is called whenever the viewport or window is changed.
  15326. C
  15327. C Arguments: none
  15328. C
  15329. C (11-Feb-1983)
  15330. C-----------------------------------------------------------------------
  15331.       INCLUDE 'f77.PGPLOT/IN'
  15332. C
  15333. C Scale plotter in world coordinates.
  15334. C
  15335.       PGXSCL(PGID) = PGXLEN(PGID)/ABS(PGXTRC(PGID)-PGXBLC(PGID))
  15336.       PGYSCL(PGID) = PGYLEN(PGID)/ABS(PGYTRC(PGID)-PGYBLC(PGID))
  15337.       IF (PGXBLC(PGID).GT.PGXTRC(PGID)) THEN
  15338.           PGXSCL(PGID) = -PGXSCL(PGID)
  15339.       END IF
  15340.       IF (PGYBLC(PGID).GT.PGYTRC(PGID)) THEN
  15341.           PGYSCL(PGID) = -PGYSCL(PGID)
  15342.       END IF
  15343.       PGXORG(PGID) = PGXOFF(PGID)-PGXBLC(PGID)*PGXSCL(PGID)
  15344.       PGYORG(PGID) = PGYOFF(PGID)-PGYBLC(PGID)*PGYSCL(PGID)
  15345.       CALL GRTRN0(PGXORG(PGID),PGYORG(PGID),
  15346.      1            PGXSCL(PGID),PGYSCL(PGID))
  15347. C
  15348. C Window plotter in viewport.
  15349. C
  15350.       CALL GRAREA(PGID,PGXOFF(PGID),PGYOFF(PGID),
  15351.      1            PGXLEN(PGID),PGYLEN(PGID))
  15352.       END
  15353. C*PGWEDG -- annotate an image plot with a wedge
  15354. C%void cpgwedg(const char *side, float disp, float width, \
  15355. C% float fg, float bg, const char *label);
  15356. C+
  15357.       SUBROUTINE PGWEDG(SIDE, DISP, WIDTH, FG, BG, LABEL)
  15358.       CHARACTER *(*) SIDE,LABEL
  15359.       REAL DISP, WIDTH, FG, BG
  15360. C
  15361. C Plot an annotated grey-scale or color wedge parallel to a given axis
  15362. C of the the current viewport. This routine is designed to provide a
  15363. C brightness/color scale for an image drawn with PGIMAG or PGGRAY.
  15364. C The wedge will be drawn with the transfer function set by PGSITF
  15365. C and using the color index range set by PGSCIR.
  15366. C
  15367. C Arguments:
  15368. C  SIDE   (input)  : The first character must be one of the characters
  15369. C                    'B', 'L', 'T', or 'R' signifying the Bottom, Left,
  15370. C                    Top, or Right edge of the viewport.
  15371. C                    The second character should be 'I' to use PGIMAG
  15372. C                    to draw the wedge, or 'G' to use PGGRAY.
  15373. C  DISP   (input)  : the displacement of the wedge from the specified
  15374. C                    edge of the viewport, measured outwards from the
  15375. C                    viewport in units of the character height. Use a
  15376. C                    negative value to write inside the viewport, a
  15377. C                    positive value to write outside.
  15378. C  WIDTH  (input)  : The total width of the wedge including annotation,
  15379. C                    in units of the character height.
  15380. C  FG     (input)  : The value which is to appear with shade
  15381. C                    1 ("foreground"). Use the values of FG and BG
  15382. C                    that were supplied to PGGRAY or PGIMAG.
  15383. C  BG     (input)  : the value which is to appear with shade
  15384. C                    0 ("background").
  15385. C  LABEL  (input)  : Optional units label. If no label is required
  15386. C                    use ' '.
  15387. C--
  15388. C  15-Oct-1992: New routine (MCS)
  15389. C   2-Aug-1995: no longer needs common (TJP).
  15390. C-----------------------------------------------------------------------
  15391.       LOGICAL PGNOTO
  15392. C                                        Temporary window coord storage.
  15393.       REAL WXA,WXB,WYA,WYB, XA,XB,YA,YB
  15394. C                                        Viewport coords of wedge.
  15395.       REAL VXA,VXB,VYA,VYB
  15396. C                          Original and anotation character heights.
  15397.       REAL OLDCH, NEWCH
  15398. C                          Size of unit character height (NDC units).
  15399.       REAL NDCSIZ
  15400. C                          True if wedge plotted horizontally.
  15401.       LOGICAL HORIZ
  15402. C                          Use PGIMAG (T) or PGGRAY (F).
  15403.       LOGICAL IMAGE
  15404. C                          Symbolic version of SIDE.
  15405.       INTEGER NSIDE,BOT,TOP,LFT,RGT
  15406.       PARAMETER (BOT=1,TOP=2,LFT=3,RGT=4)
  15407.       INTEGER I
  15408.       REAL WEDWID, WDGINC, VWIDTH, VDISP, XCH, YCH, LABWID, FG1, BG1
  15409. C                          Set the fraction of WIDTH used for anotation.
  15410.       REAL TXTFRC
  15411.       PARAMETER (TXTFRC=0.6)
  15412. C                          Char separation between numbers and LABEL.
  15413.       REAL TXTSEP
  15414.       PARAMETER (TXTSEP=2.2)
  15415. C                          Array to draw wedge in.
  15416.       INTEGER WDGPIX
  15417.       PARAMETER (WDGPIX=100)
  15418.       REAL WDGARR(WDGPIX)
  15419. C                          Define the coordinate-mapping function.
  15420.       REAL TR(6)
  15421.       SAVE TR
  15422.       DATA TR /0.0,1.0,0.0,0.0,0.0,1.0/
  15423. C-----------------------------------------------------------------------
  15424.       IF(PGNOTO('PGWEDG')) RETURN
  15425. C
  15426. C Get a numeric version of SIDE.
  15427. C
  15428.       IF(SIDE(1:1).EQ.'B' .OR. SIDE(1:1).EQ.'b') THEN
  15429.         NSIDE = BOT
  15430.         HORIZ = .TRUE.
  15431.       ELSE IF(SIDE(1:1).EQ.'T' .OR. SIDE(1:1).EQ.'t') THEN
  15432.         NSIDE = TOP
  15433.         HORIZ = .TRUE.
  15434.       ELSE IF(SIDE(1:1).EQ.'L' .OR. SIDE(1:1).EQ.'l') THEN
  15435.         NSIDE = LFT
  15436.         HORIZ = .FALSE.
  15437.       ELSE IF(SIDE(1:1).EQ.'R' .OR. SIDE(1:1).EQ.'r') THEN
  15438.         NSIDE = RGT
  15439.         HORIZ = .FALSE.
  15440.       ELSE
  15441.         CALL GRWARN('Invalid "SIDE" argument in PGWEDG.')
  15442.         RETURN
  15443.       END IF
  15444. C
  15445. C Determine which routine to use.
  15446. C
  15447.       IF (LEN(SIDE).LT.2) THEN
  15448.          IMAGE = .FALSE.
  15449.       ELSE IF(SIDE(2:2).EQ.'I' .OR. SIDE(2:2).EQ.'i') THEN
  15450.          IMAGE = .TRUE.
  15451.       ELSE IF(SIDE(2:2).EQ.'G' .OR. SIDE(2:2).EQ.'g') THEN
  15452.          IMAGE = .FALSE.
  15453.       ELSE
  15454.          CALL GRWARN('Invalid "SIDE" argument in PGWEDG.')
  15455.       END IF
  15456. C
  15457.       CALL PGBBUF
  15458. C
  15459. C Store the current world and viewport coords and the character height.
  15460. C
  15461.       CALL PGQWIN(WXA, WXB, WYA, WYB)
  15462.       CALL PGQVP(0, XA, XB, YA, YB)
  15463.       CALL PGQCH(OLDCH)
  15464. C
  15465. C Determine the unit character height in NDC coords.
  15466. C
  15467.       CALL PGSCH(1.0)
  15468.       CALL PGQCS(0, XCH, YCH)
  15469.       IF(HORIZ) THEN
  15470.         NDCSIZ = YCH
  15471.       ELSE
  15472.         NDCSIZ = XCH
  15473.       END IF
  15474. C
  15475. C Convert 'WIDTH' and 'DISP' into viewport units.
  15476. C
  15477.       VWIDTH = WIDTH * NDCSIZ * OLDCH
  15478.       VDISP  = DISP * NDCSIZ * OLDCH
  15479. C
  15480. C Determine the number of character heights required under the wedge.
  15481. C
  15482.       LABWID = TXTSEP
  15483.       IF(LABEL.NE.' ') LABWID = LABWID + 1.0
  15484. C
  15485. C Determine and set the character height required to fit the wedge
  15486. C anotation text within the area allowed for it.
  15487. C
  15488.       NEWCH = TXTFRC*VWIDTH / (LABWID*NDCSIZ)
  15489.       CALL PGSCH(NEWCH)
  15490. C
  15491. C Determine the width of the wedge part of the plot minus the anotation.
  15492. C (NDC units).
  15493. C
  15494.       WEDWID = VWIDTH * (1.0-TXTFRC)
  15495. C
  15496. C Use these to determine viewport coordinates for the wedge + annotation.
  15497. C
  15498.       VXA = XA
  15499.       VXB = XB
  15500.       VYA = YA
  15501.       VYB = YB
  15502.       IF(NSIDE.EQ.BOT) THEN
  15503.         VYB = YA - VDISP
  15504.         VYA = VYB - WEDWID
  15505.       ELSE IF(NSIDE.EQ.TOP) THEN
  15506.         VYA = YB + VDISP
  15507.         VYB = VYA + WEDWID
  15508.       ELSE IF(NSIDE.EQ.LFT) THEN
  15509.         VXB = XA - VDISP
  15510.         VXA = VXB - WEDWID
  15511.       ELSE IF(NSIDE.EQ.RGT) THEN
  15512.         VXA = XB + VDISP
  15513.         VXB = VXA + WEDWID
  15514.       END IF
  15515. C
  15516. C Set the viewport for the wedge.
  15517. C
  15518.       CALL PGSVP(VXA, VXB, VYA, VYB)
  15519. C
  15520. C Swap FG/BG if necessary to get axis direction right.
  15521. C
  15522.       FG1 = MAX(FG,BG)
  15523.       BG1 = MIN(FG,BG)
  15524. C
  15525. C Create a dummy wedge array to be plotted.
  15526. C
  15527.       WDGINC = (FG1-BG1)/(WDGPIX-1)
  15528.       DO 1 I=1,WDGPIX
  15529.         WDGARR(I) = BG1 + (I-1) * WDGINC
  15530.  1    CONTINUE
  15531. C
  15532. C Draw the wedge then change the world coordinates for labelling.
  15533. C
  15534.       IF (HORIZ) THEN
  15535.         CALL PGSWIN(1.0, REAL(WDGPIX), 0.9, 1.1)
  15536.         IF (IMAGE) THEN
  15537.            CALL PGIMAG(WDGARR, WDGPIX,1, 1,WDGPIX, 1,1, FG,BG, TR)
  15538.         ELSE
  15539.            CALL PGGRAY(WDGARR, WDGPIX,1, 1,WDGPIX, 1,1, FG,BG, TR)
  15540.         END IF
  15541.         CALL PGSWIN(BG1,FG1,0.0,1.0)
  15542.       ELSE
  15543.         CALL PGSWIN(0.9, 1.1, 1.0, REAL(WDGPIX))
  15544.         IF (IMAGE) THEN
  15545.            CALL PGIMAG(WDGARR, 1,WDGPIX, 1,1, 1,WDGPIX, FG,BG, TR)
  15546.         ELSE
  15547.            CALL PGGRAY(WDGARR, 1,WDGPIX, 1,1, 1,WDGPIX, FG,BG, TR)
  15548.         END IF
  15549.         CALL PGSWIN(0.0, 1.0, BG1, FG1)
  15550.       ENDIF
  15551. C
  15552. C Draw a labelled frame around the wedge.
  15553. C
  15554.       IF(NSIDE.EQ.BOT) THEN
  15555.         CALL PGBOX('BCNST',0.0,0,'BC',0.0,0)
  15556.       ELSE IF(NSIDE.EQ.TOP) THEN
  15557.         CALL PGBOX('BCMST',0.0,0,'BC',0.0,0)
  15558.       ELSE IF(NSIDE.EQ.LFT) THEN
  15559.         CALL PGBOX('BC',0.0,0,'BCNST',0.0,0)
  15560.       ELSE IF(NSIDE.EQ.RGT) THEN
  15561.         CALL PGBOX('BC',0.0,0,'BCMST',0.0,0)
  15562.       ENDIF
  15563. C
  15564. C Write the units label.
  15565. C
  15566.       IF(LABEL.NE.' ') THEN
  15567.         CALL PGMTXT(SIDE,TXTSEP,1.0,1.0,LABEL)
  15568.       END IF
  15569. C
  15570. C Reset the original viewport and world coordinates.
  15571. C
  15572.       CALL PGSVP(XA,XB,YA,YB)
  15573.       CALL PGSWIN(WXA,WXB,WYA,WYB)
  15574.       CALL PGSCH(OLDCH)
  15575.       CALL PGEBUF
  15576.       RETURN
  15577.       END
  15578. C*PGWINDOW -- non-standard alias for PGSWIN
  15579. C+
  15580.       SUBROUTINE PGWINDOW (X1, X2, Y1, Y2)
  15581.       REAL X1, X2, Y1, Y2
  15582. C
  15583. C See description of PGSWIN.
  15584. C--
  15585.       CALL PGSWIN (X1, X2, Y1, Y2)
  15586.       END
  15587. C*PGWNAD -- set window and adjust viewport to same aspect ratio
  15588. C%void cpgwnad(float x1, float x2, float y1, float y2);
  15589. C+
  15590.       SUBROUTINE PGWNAD (X1, X2, Y1, Y2)
  15591.       REAL X1, X2, Y1, Y2
  15592. C
  15593. C Change the window in world coordinate space that is to be mapped on
  15594. C to the viewport, and simultaneously adjust the viewport so that the
  15595. C world-coordinate scales are equal in x and y. The new viewport is
  15596. C the largest one that can fit within the previously set viewport
  15597. C while retaining the required aspect ratio.
  15598. C
  15599. C Arguments:
  15600. C  X1     (input)  : the x-coordinate of the bottom left corner
  15601. C                    of the viewport.
  15602. C  X2     (input)  : the x-coordinate of the top right corner
  15603. C                    of the viewport (note X2 may be less than X1).
  15604. C  Y1     (input)  : the y-coordinate of the bottom left corner
  15605. C                    of the viewport.
  15606. C  Y2     (input)  : the y-coordinate of the top right corner of the
  15607. C                    viewport (note Y2 may be less than Y1).
  15608. C--
  15609. C 25-Sep-1985 - new routine (TJP).
  15610. C 31-May-1989 - correct error: XVP and YVP not set (TJP).
  15611. C-----------------------------------------------------------------------
  15612.       INCLUDE 'f77.PGPLOT/IN'
  15613.       LOGICAL PGNOTO
  15614.       REAL SCALE,OXLEN,OYLEN
  15615. C
  15616.       IF (PGNOTO('PGWNAD')) RETURN
  15617. C
  15618. C If invalid arguments are specified, issue warning and leave window
  15619. C unchanged.
  15620. C
  15621.       IF (X1.EQ.X2) THEN
  15622.          CALL GRWARN('invalid x limits in PGWNAD: X1 = X2.')
  15623.       ELSE IF (Y1.EQ.Y2) THEN
  15624.          CALL GRWARN('invalid y limits in PGWNAD: Y1 = Y2.')
  15625.       ELSE
  15626.          SCALE = MIN(PGXLEN(PGID)/ABS(X2-X1)/PGXPIN(PGID), 
  15627.      1               PGYLEN(PGID)/ABS(Y2-Y1)/PGYPIN(PGID))
  15628.          PGXSCL(PGID) = SCALE*PGXPIN(PGID)
  15629.          PGYSCL(PGID) = SCALE*PGYPIN(PGID)
  15630.          OXLEN = PGXLEN(PGID)
  15631.          OYLEN = PGYLEN(PGID)
  15632.          PGXLEN(PGID) = PGXSCL(PGID)*ABS(X2-X1)
  15633.          PGYLEN(PGID) = PGYSCL(PGID)*ABS(Y2-Y1)
  15634.          PGXVP(PGID)  = PGXVP(PGID) + 0.5*(OXLEN-PGXLEN(PGID))
  15635.          PGYVP(PGID)  = PGYVP(PGID) + 0.5*(OYLEN-PGYLEN(PGID))
  15636.          PGXOFF(PGID) = PGXVP(PGID) + (PGNXC(PGID)-1)*PGXSZ(PGID)
  15637.          PGYOFF(PGID) = PGYVP(PGID) +
  15638.      1                   (PGNY(PGID)-PGNYC(PGID))*PGYSZ(PGID)
  15639.          CALL PGSWIN(X1, X2, Y1, Y2)
  15640.       END IF
  15641.       END
  15642.       INCLUDE 'SYS_ARC.f77.ArcInclude'
  15643.